ERLANDSEN DATA CONSULTING Excel & VBA Tips   Informasjon på norsk / Information in Norwegian

These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Copy data from multiple workbooks

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

 

Document last updated 2008-04-30 22:33:25      Printerfriendly version

 

Erlandsen Data Consulting     http://www.erlandsendata.no/   
Excel & VBA Tips   Copyright ©1999-2024    Ole P. Erlandsen   All rights reserved
E-mail Contact Address