how do i combine data from multiple sheets into one sheet?

[David W. Owens]

I was given 9 Excel files, each containing 27 sheets (A to Z and Memo). Each
sheet contains 3 cols: Name, Date, Page.
Example: Sheet named “Aâ€, contains people whose name begins with an “A†and
has a data and a page number. Sheet named “Bâ€, contains people whose name
begins with a “B†and has a data and a page number. And so on. I want to
combine all the names in the “A†Sheet. The Memo Sheet will be ignored.
This is the first step for 9 files.

Each of the 9 files is a decade of 10 years, and I want to combine all the
Names a 10 year file, then combine all the files into one file.

Cut and Paste is slow for 27 sheets, and doesnt work.

 

[Joel]

Put all 9 workbooks in a folder making sure they are the only XLS file in the
folder. Then change the name of the Folder in the macro below to match the
folder where the files are lcoated.

Sub combinebooks()

Folder = "c:\temp\"

FName = Dir(Folder & "*.xls")

First = True 'used to indicate when first workbook is added
Do While FName <> ""
Set oldbk = Workbooks.Open(Filename:=Folder & FName)
For Each sht In oldbk.Sheets
If First = True Then
'simply copy the worksheets to thisworkbook
With ThisWorkbook
sht.Copy after:=.Sheets(.Sheets.Count)
End With
Else
LastRow = sht.Range("A" & Rows.Count).End(xlUp).Row
sht.Rows("1:" & LastRow).Copy
With ThisWorkbook.Sheets(sht.Name)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If .Range("A1") = "" Then
'if sheet is empty
NewRow = 1
Else
'if sheet is not empty
NewRow = LastRow + 1
End If
.Rows(NewRow).Paste
End With
End If
Next
First = False
oldbk.Close savechanges:=False
FName = Dir()
Loop
End Sub

 

[Dave Peterson]

This compiled, but I didn't test it:

Option Explicit
Sub testme()
Dim WkbkNames As Variant
Dim TempWkbk As Workbook
Dim NextRow As Long
Dim RngToCopy As Range
Dim Wks As Worksheet 'for all the worksheets in all the workbooks
Dim lCtr As Long 'letter counter
Dim fCtr As Long 'file counter
Dim CombWkbk As Workbook


'give all 9 names--include path and filename.
WkbkNames = Array("C:\my documents\excel\test\book1.xls", _
"C:\my documents\excel\test\book2.xls", _
"C:\my documents\excel\test\book3.xls", _
"C:\my documents\excel\test\book4.xls")

Set CombWkbk = Workbooks.Add(1)
CombWkbk.Worksheets(1).Name = "DeleteMeLater"

For fCtr = LBound(WkbkNames) To UBound(WkbkNames)

Set TempWkbk = Nothing
On Error Resume Next
Set TempWkbk = Workbooks.Open(Filename:=WkbkNames(fCtr), ReadOnly:=True)
On Error GoTo 0

If TempWkbk Is Nothing Then
MsgBox WkbkNames(fCtr) & " wasn't found/opened"
Else
For lCtr = Asc("A") To Asc("Z")
If WorksheetExists(Chr(lCtr), TempWkbk) = False Then
MsgBox TempWkbk.Name _
& " didn't have worksheet: " & Chr(lCtr)
Else
Set Wks = TempWkbk.Worksheets(Chr(lCtr))

If fCtr = LBound(WkbkNames) Then
'first workbook opened
Wks.Copy _
after:=CombWkbk.Worksheets _
(CombWkbk.Worksheets.Count)
Else
With CombWkbk.Worksheets(Chr(lCtr))
NextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Row + 1
End With

With Wks
'avoid headers in row 1
Set RngToCopy = .Range("a2:C" _
& .Cells(.Rows.Count, "A") _
.End(xlUp).Row)
End With

RngToCopy.Copy _
Destination:=CombWkbk.Worksheets(Chr(lCtr)) _
.Cells(NextRow, "A")
End If
End If
Next lCtr
TempWkbk.Close savechanges:=False
End If
Next fCtr
If CombWkbk.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
CombWkbk.Worksheets("DeleteMeLater").Delete
Application.DisplayAlerts = False
MsgBox "Remember to save the combined workbook!"
Else
CombWkbk.Close savechanges:=False
MsgBox "Nothing was combined. What happened???"
End If
End Sub
Function WorksheetExists(SheetName As Variant, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

 

[Dave Peterson]

There is a bug in my first suggestion that would appear if the first workbook
wasn't opened or it was missing any of the sheets.

This corrects that bug:

Option Explicit
Sub testme()
Dim WkbkNames As Variant
Dim TempWkbk As Workbook
Dim NextRow As Long
Dim RngToCopy As Range
Dim Wks As Worksheet 'for all the worksheets in all the workbooks
Dim lCtr As Long 'letter counter
Dim fCtr As Long 'file counter
Dim CombWkbk As Workbook

'give all 9 names--include path and filename.
WkbkNames = Array("C:\my documents\excel\test\book1.xls", _
"C:\my documents\excel\test\book2.xls", _
"C:\my documents\excel\test\book3.xls", _
"C:\my documents\excel\test\book4.xls")

Set CombWkbk = Workbooks.Add(1)
CombWkbk.Worksheets(1).Name = "DeleteMeLater"

For lCtr = Asc("Z") To Asc("A") Step -1
CombWkbk.Worksheets.Add.Name = Chr(lCtr)
CombWkbk.Worksheets(Chr(lCtr)).Range("a1").Resize(1, 3).Value _
= Array("Name", "Date", "Page")
Next lCtr

Application.DisplayAlerts = False
CombWkbk.Worksheets("Deletemelater").Delete
Application.DisplayAlerts = True

For fCtr = LBound(WkbkNames) To UBound(WkbkNames)

Set TempWkbk = Nothing
On Error Resume Next
Set TempWkbk = Workbooks.Open(Filename:=WkbkNames(fCtr), ReadOnly:=True)
On Error GoTo 0

If TempWkbk Is Nothing Then
MsgBox WkbkNames(fCtr) & " wasn't found/opened"
Else
For lCtr = Asc("A") To Asc("Z")
If WorksheetExists(Chr(lCtr), TempWkbk) = False Then
MsgBox TempWkbk.Name _
& " didn't have worksheet: " & Chr(lCtr)
Else
Set Wks = TempWkbk.Worksheets(Chr(lCtr))

With CombWkbk.Worksheets(Chr(lCtr))
NextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Row + 1
End With

With Wks
'avoid headers in row 1
Set RngToCopy = .Range("a2:C" _
& .Cells(.Rows.Count, "A") _
.End(xlUp).Row)
End With

RngToCopy.Copy _
Destination:=CombWkbk.Worksheets(Chr(lCtr)) _
.Cells(NextRow, "A")

End If
Next lCtr
TempWkbk.Close savechanges:=False
End If
Next fCtr
End Sub
Function WorksheetExists(SheetName As Variant, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function