Copy data from multiple workbooks
2008-04-30 Workbooks 2 220
The macro below can be used to copy a cell range from one or all worksheets in one or more workbooks to a new workbook.
You will need to customize the example macro a little to make it fit your needs.
Sub TestCopyDataFromMultipleWorkbooks() ' updated 2008-04-30 by OPE Dim varWorkbooks As Variant, wb As Workbook varWorkbooks = "Excel Workbooks (*.xl*),*.xl*,All Files (*.*),*.*" varWorkbooks = Application.GetOpenFilename(varWorkbooks, 1, _ "Select one or more workbooks to copy data from (Ctrl+A selects all items in the folder)", , True) If Not IsArray(varWorkbooks) Then Exit Sub ' the user cancelled the dialog With Application .ScreenUpdating = False .Cursor = xlWait End With Set wb = Workbooks.Add ' create the new report workbook ' the following line(s) must be customized for each copy task ' copy from one named worksheet: CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, "Sheet1", "A1:D10" ' copy from the first (or another numbered) worksheet: 'CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, 1, "A1:D10" ' copy from all worksheets: 'CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, vbNullString, "A1:D10" wb.Activate Set wb = Nothing With Application .Cursor = xlDefault .StatusBar = False .ScreenUpdating = True End With End Sub Sub CopyDataFromMultipleWorkbooks(wsTarget As Worksheet, varWorkbooks As Variant, _ varWorksheet As Variant, strWorksheetRange As String) ' updated 2008-04-30 by OPE Dim r As Long, i As Long, wb As Workbook, ws As Worksheet, rng As Range If wsTarget Is Nothing Then Exit Sub ' no target workbook ' assumes that wsTarget is a new unfiltered worksheet If Not IsArray(varWorkbooks) Then Exit Sub ' invalid input For i = LBound(varWorkbooks) To UBound(varWorkbooks) On Error Resume Next Set wb = Workbooks.Add(varWorkbooks(i)) ' try to open a copy of the workbook On Error GoTo 0 If Not wb Is Nothing Then With wb Application.StatusBar = "Copying information from " & varWorkbooks(i) & "..." If Len(varWorksheet) = 0 Then ' no worksheet name specified, copy from all worksheets For Each ws In .Worksheets With wsTarget ' find the next target row to paste the copied content ' the following line assumes that column A always is populated r = .Range("A" & .Rows.Count).End(xlUp).Row + 1 End With On Error Resume Next Set rng = ws.Range(strWorksheetRange) If Not rng Is Nothing Then ' the range exists rng.Copy wsTarget.Range("A" & r) ' copy the source range to the target worksheet Set rng = Nothing End If On Error GoTo 0 Next ws Set ws = Nothing Else ' copy from one worksheet On Error Resume Next Set ws = wb.Worksheets(varWorksheet) On Error GoTo 0 If Not ws Is Nothing Then ' the worksheet exists With wsTarget ' find the next target row to paste the copied content ' the following line assumes that column A always is populated r = .Range("A" & .Rows.Count).End(xlUp).Row + 1 End With On Error Resume Next Set rng = ws.Range(strWorksheetRange) If Not rng Is Nothing Then ' the range exists rng.Copy wsTarget.Range("A" & r) ' copy the source range to the target worksheet Set rng = Nothing End If On Error GoTo 0 Set ws = Nothing End If End If .Close False ' close the workbook copy without saving any changes Application.StatusBar = False End With Set wb = Nothing End If Next i ' next workbook End Sub