See if this code works better. The code checks all the xls files inthe
folder called folder (change as required) and combines all the sheets into a
summary table. I did not get a chance to fully test the code. It should
work. The code assumes each workbook has a header in row 1 and ther are no
errors in the cells like #VALUE. It copies the formating but removes any
formulas. I needed to copy the formating because Dates were getting
transposed to number.

Sub Combinebooks()

Application.ScreenUpdating = False
'Assume the summary book is completeley blank

Folder = "c:\temp\"

NewRow = 2
NewCol = 1
FName = Dir(Folder & "*.xls")
With ThisWorkbook.Sheets("Sheet1")
Do While FName < ""
Set bk = Workbooks.Open(Filename:=Folder & FName)
'check header to see if there are any new headers not
'in summary sheet
For Each sht In bk.Sheets
LastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

LastCol = sht.Cells(1, Columns.Count).End(xlToLeft).Column

'move all the data
For RowCount = 2 To LastRow
For ColCount = 1 To LastCol
ColHeader = sht.Cells(1, ColCount)
If ColHeader < "" Then
'search for header in summary sheet
Set c = .Rows(1).Find(what:=ColHeader, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
'add header
.Cells(1, NewCol) = ColHeader
DataCol = NewCol
NewCol = NewCol + 1

Else
DataCol = c.Column
End If

If sht.Cells(RowCount, ColCount) < "" Then
sht.Cells(RowCount, ColCount).Copy _
Destination:=.Cells(NewRow, DataCol)
'remove formulas
.Cells(NewRow, DataCol).Copy
.Cells(NewRow, DataCol).PasteSpecial _
Paste:=xlPasteValues
End If
End If
Next ColCount
NewRow = NewRow + 1
Next RowCount
Next sht

bk.Close savechanges:=False
FName = Dir()
Loop
End With
Application.ScreenUpdating = True

End Sub



"Steve" wrote:

Hi,

I am needing a VBA script to combine multiple workbooks of multiple sheets
to a single worksheet. Basically i have a lot of workbooks which have all the
same headers but i want to combine all of these into one big speadsheet.

I have found the script below which i have tried to use but it copies over
the top of every worksheet so it will only show the last one.

any ideas of how i can make it join to the bottom rather than over the top?

thank you!


Sub ImportDistricts()

Dim x As Long, z As Variant
Dim bk As Workbook, sh As Worksheet
Dim sh1 As Worksheet

'
' Change the next line to reflect the proper
' name and workbook where the data will be
' consolidated
'

Set sh = Workbooks("SummaryBecsAll.xls").Worksheets("BecsAl l")


z = Application.GetOpenFilename(FileFilter:= _
"Excel files (*.xls), *.xls", MultiSelect:=True)
If Not IsArray(z) Then
MsgBox "Nothing selected"
Exit Sub
End If

'Open loop for action to be taken on all selected workbooks.

For x = 1 To UBound(z)

'Open the workbook(s) that were selected.
Set bk = Workbooks.Open(z(x))
'Check if sheet Mon1 exists
'Check if sheet Mon2 exists
'Check if sheet Mon3 exists
'Check if sheet Mon4 exists
'Check if sheet Mon5 exists
'Dont process a sheet if its name is "cover"
On Error Resume Next
Set sh1 = bk.Worksheets("Mon1")
Set sh1 = bk.Worksheets("Mon2")
Set sh1 = bk.Worksheets("Mon3")
Set sh1 = bk.Worksheets("Mon4")
Set sh1 = bk.Worksheets("Mon5")
On Error GoTo 0
' if it exists, copy the data
If Not sh1 Is Nothing Then
Set rng = sh1.Range("A2:X1646")
Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2)
rng.Copy
rng1.PasteSpecial xlValues
rng1.PasteSpecial xlFormats
End If

'Close the District workbook without saving it.
bk.Close False

Next x


'Message box to inform user the job is complete.
MsgBox "The import is complete.", 64, "Done !!"
End Sub