Copy data from multiple workbooks

 2008-04-30    Workbooks    2    49

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


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.

OPE | 2009-02-25 23:05:00 (GMT)

You can try something like the example below, it is not tested, but you should get a general idea about how to do what you asked.

Sub AnotherSolution()
Dim varItems As Variant, strTargetWS As String, i As Long, strItem As String
' read workbook names from the active worksheet
varItems = Application.Transpose(Range("E1:E100").Value)
' read the target worksheet name from a cell in the active worksheet
strTargetWS = Range("B1").Value
If Len(strTargetWS) = 0 Then Exit Sub

For i = LBound(varItems) To UBound(varItems)
strItem = varItems(i)
If Len(strItem) > 0 Then
If InStr(1, strItem, Application.PathSeparator, vbBinaryCompare) = 0 Then
' add the active workbook path if no path is present in the file name
strItem = ActiveWorkbook.Path & Application.PathSeparator & strItem
End If
CopyDataFromMultipleWorkbooks ActiveWorkbook.Worksheets(strTargetWS), strItem, "Sheet1", "A1:D10"
End If
Next i
End Sub

Tony Wilson | 2009-02-25 22:01:19 (GMT)

Excellent macro. Could you tell me how I can use this; but specify a list of workbooks to open from a list within the current/master workbook that you are about to copy data to please.

E.G Worksheet "Projects" has a list of the workbooks in column E "Project1.xls, Project 2a.xls, Project 2B.xls" e.t.c.

How do I get the macro to read this list of workbooks and use this list to copy data from please?

If it is possible can I also tell it the worksheet(in the current/master workbook) to copy the data to?