Import Data Multiple WB

[JoeExcelHelp]

I have this code that I've been using for a while and it works great but I need to take it to another level :)

Would like it to:
Retrieve data from multiple WB(s) and sheets within them (Range A2:M?) (Number of rows are dynamic but A2 thru M is constant on all WB sheets)
Would like to manually enter the WB names and sheet names in the code as they are also dynamic
the (Destination.xlsm) has a sheet name (Summary) where all data is collected starting in row 2 column 1
Once I run the code it removes old data in (Summary) and replaces it with new records from the WB's

Thank You for all the ongoing help

Code: Select all

Sub SummurizeSheets()
    Dim ws As Worksheet
     
    Application.ScreenUpdating = False
    Sheets("Summary").Activate
     
    For Each ws In Worksheets
        If ws.Name <> "Summary" Then
            ws.Range("A2:I2").Copy
            Worksheets("Summary").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
        End If
    Next ws
End Sub

[Rudi]

Would like to manually enter the WB names and sheet names in the code as they are also dynamic

Would it not be easier to have the Open Dialog show and you can select the workbooks you want to collect data from as opposed to manually entering the names of the workbooks?
As for the sheets in the workbooks to process; do you really want to manually supply these too, or can it process all sheets in the workbooks identified, or maybe sheets based on a condition?

[Rudi]

This should provide a starting point to work from...

Code: Select all

Sub MergeSelectedWorkbooks()
Dim shSummary As Worksheet
Dim vFiles As Variant
Dim sFileName As String
Dim lCnt As Long
Dim wb As Workbook
Dim sh As Worksheet

    Set shSummary = ThisWorkbook.Worksheets("Summary")
    vFiles = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    If TypeName(vFiles) = "Boolean" Then
        MsgBox "No files were selected." & vbNewLine & _
            "The macro will now quit.", vbExclamation
        Exit Sub
    End If
    Application.ScreenUpdating = False
    shSummary.Cells.Clear
    For lCnt = LBound(vFiles) To UBound(vFiles)
        sFileName = vFiles(lCnt)
        Set wb = Workbooks.Open(sFileName)
        For Each sh In wb.Sheets
            sh.Range("A1", sh.Cells(Rows.Count, "H").End(xlUp)).Copy _
                shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1)
        Next sh
        wb.Close SaveChanges:=False
    Next lCnt
    shSummary.Columns.AutoFit
    Application.ScreenUpdating = True
    MsgBox "Data from all files collected.", vbInformation
End Sub

[JoeExcelHelp]

Thanks Rudi, all great questions and smart.. I'm not the administrator for these WB's so let me find out

[JoeExcelHelp]

Hi Rudi,

I attached the destination.xlsm WB that explains things further with respect to the WB names

Location of WB's:
C:\Users\gg70397\Tracing\Documents\
Sheets:
Any sheet that contains AO or GO

[JoeExcelHelp]

I should say any sheet that has AO or GO in its title.. really appreciate the assistance

[Rudi]

Hi,

Here is the code based on the new information you supplied.
I have attached the updated workbook you supplied too.

Please note:
Currently the code is checking the sheet name if it contains "AO" or "GO". (InStr(1, UCase(sh.Name)...
You refer to the sheet title. I initially took it for the sheet name, but if Title is actually the heading of the sheet (as in cell A1), then replace UCase(sh.Name) with the following: InStr(1, UCase(sh.Range("A1").Value)... (Adjust the range reference as needed to point to the Title).

Code: Select all

Sub MergeSelectedWorkbooks()
Dim shSummary As Worksheet
Dim rgFiles As Range
Dim rgC As Range
Dim sFileName As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCnt As Long
Dim sMsg As String

Const sPath = "C:\Users\gg70397\Tracing\Documents\" ' << Change path as needed...
    
    lCnt = 0
    Set shSummary = ThisWorkbook.Worksheets("Summary")
    Set rgBooks = ThisWorkbook.Sheets("WB Names").Range("A1").CurrentRegion
    Set rgFiles = Intersect(rgBooks, rgBooks.Offset(1))
    If rgFiles Is Nothing Then
        MsgBox "No files were listed on the 'WB Names' sheet!" & vbNewLine & _
            "The macro will now quit.", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    Application.ScreenUpdating = False
    rgFiles.Interior.Color = xlNone
    shSummary.UsedRange.Offset(1).Clear
    On Error Resume Next
    For Each rgC In rgFiles.Cells
        sFileName = rgC.Value
        Set wb = Workbooks.Open(sPath & sFileName)
        If Not wb Is Nothing Then
            For Each sh In wb.Sheets
                If InStr(1, UCase(sh.Name), "AO") > 0 Or InStr(1, UCase(sh.Name), "GO") > 0 Then
                    sh.Range("A2", sh.Cells(Rows.Count, "M").End(xlUp)).Copy _
                        shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1)
                End If
            Next sh
            wb.Close SaveChanges:=False
        Else
            rgC.Interior.Color = vbRed
            lCnt = lCnt + 1
        End If
        Set wb = Nothing
        sFileName = ""
    Next rgC
    On Error GoTo 0
    shSummary.Columns.AutoFit
    Application.ScreenUpdating = True
    If lCnt > 0 Then
        sMsg = "The macro completed its run, but some (or all) files were not found! " & _
                "Files not found are marked in red on the 'WB Names' sheet."
        MsgBox sMsg, vbExclamation
    Else
        sMsg = "Data from all files collected."
        MsgBox sMsg, vbInformation
    End If
End Sub

Destination.xlsm

[JoeExcelHelp]

Hi Rudi.. Thank you so much for the help
I attached a sample WB (April 6 2016.xlsx) the code will be pulling data from
When I run the code it seems to pull headers on all tabs (would like to exclude that)
I'm always trying to learn so I was wondering would this part of the code exlcude that being that it starts on A2?
sh.Range("A2", sh.Cells(Rows.Count, "P").End(xlUp)).Copy

[JoeExcelHelp]

Also it seems to be only pulling in only 1 record from each sheet

[Rudi]

Hi

Try this version. I have updated the code to respond more dynamically on the data size.

Code: Select all

Sub MergeSelectedWorkbooks()
Dim shSummary As Worksheet
Dim rgFiles As Range
Dim rgC As Range
Dim sFileName As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCnt As Long
Dim sMsg As String

Const sPath = "C:\Users\gg70397\Tracing\Documents\" ' << Change path as needed...
    
    lCnt = 0
    Set shSummary = ThisWorkbook.Worksheets("Summary")
    Set rgBooks = ThisWorkbook.Sheets("WB Names").Range("A1").CurrentRegion
    Set rgFiles = Intersect(rgBooks, rgBooks.Offset(1))
    If rgFiles Is Nothing Then
        MsgBox "No files were listed on the 'WB Names' sheet!" & vbNewLine & _
            "The macro will now quit.", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    Application.ScreenUpdating = False
    rgFiles.Interior.Color = xlNone
    shSummary.UsedRange.Offset(1).Clear
    On Error Resume Next
    For Each rgC In rgFiles.Cells
        sFileName = rgC.Value
        Set wb = Workbooks.Open(sPath & sFileName)
        If Not wb Is Nothing Then
            For Each sh In wb.Sheets
                If InStr(1, UCase(sh.Name), "AO") > 0 Or InStr(1, UCase(sh.Name), "GO") > 0 Then
                    Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy _
                        shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1)
                End If
            Next sh
            wb.Close SaveChanges:=False
        Else
            rgC.Interior.Color = vbRed
            lCnt = lCnt + 1
        End If
        Set wb = Nothing
        sFileName = ""
    Next rgC
    On Error GoTo 0
    shSummary.Columns.AutoFit
    Application.ScreenUpdating = True
    If lCnt > 0 Then
        sMsg = "The macro completed its run, but some (or all) files were not found! " & _
                "Files not found are marked in red on the 'WB Names' sheet."
        MsgBox sMsg, vbExclamation
    Else
        sMsg = "Data from all files collected."
        MsgBox sMsg, vbInformation
    End If
End Sub

[JoeExcelHelp]

Morning Rudi,

Attached is the sorece data format I'm actually trying to work with and Unfort I dont have control over this format :(
The code seems to pull in blank rows when I run it againt this source format
Also, would it be possible to just have it copy paste special values rather then all formats? I tried to modelfy the following line myself relative to special values but it doesnt work
Thank You

Code: Select all

shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial(xlPasteValues)

Code: Select all

Sub MergeSelectedWorkbooks2()
Dim shSummary As Worksheet
Dim rgFiles As Range
Dim rgC As Range
Dim sFileName As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCnt As Long
Dim sMsg As String

Const sPath = "C:\Users\gg70397\Tracing\Documents\" ' << Change path as needed...
    
    lCnt = 0
    Set shSummary = ThisWorkbook.Worksheets("Summary")
    Set rgBooks = ThisWorkbook.Sheets("WB Names").Range("A1").CurrentRegion
    Set rgFiles = Intersect(rgBooks, rgBooks.Offset(1))
    'If rgFiles Is Nothing Then
        'MsgBox "No files were listed on the 'WB Names' sheet!" & vbNewLine & _
            '"The macro will now quit.", vbExclamation
        'Application.ScreenUpdating = True
        'Exit Sub
    'End If
    Application.ScreenUpdating = False
    rgFiles.Interior.Color = xlNone
    shSummary.UsedRange.Offset(1).Clear
    On Error Resume Next
    For Each rgC In rgFiles.Cells
        sFileName = rgC.Value
        Set wb = Workbooks.Open(sPath & sFileName)
        If Not wb Is Nothing Then
            For Each sh In wb.Sheets
                If InStr(1, UCase(sh.Name), "AO") > 0 Or InStr(1, UCase(sh.Name), "GO") > 0 Then
                    Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy _
                        shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial(xlPasteValues)
                End If
            Next sh
            wb.Close SaveChanges:=False
        'Else
            'rgC.Interior.Color = vbRed
            'lCnt = lCnt + 1
        End If
        Set wb = Nothing
        sFileName = ""
    Next rgC
    On Error GoTo 0
    'shSummary.Columns.AutoFit
    Application.ScreenUpdating = True
    'If lCnt > 0 Then
        'sMsg = "The macro completed its run, but some (or all) files were not found! " & _
                '"Files not found are marked in red on the 'WB Names' sheet."
        ''MsgBox sMsg, vbExclamation
    'Else
        'sMsg = "Data from all files collected."
        'MsgBox sMsg, vbInformation
    'End If
End Sub

[HansV]

If you want to use PasteSpecial, it should be in a separate instruction. Instead of

Code: Select all

                    Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy _
                        shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial(xlPasteValues)

use

Code: Select all

                    Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy
                    shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

i.e. no _ after Copy.

The empty-looking rows contain the data from the hidden sheets. The following version skips the hidden sheets.

Code: Select all

Sub MergeSelectedWorkbooks2()
    Dim shSummary As Worksheet
    Dim rgFiles As Range
    Dim rgC As Range
    Dim sFileName As String
    Dim wb As Workbook
    Dim sh As Worksheet

    Const sPath = "C:\Users\gg70397\Tracing\Documents\" ' << Change path as needed...

    Set shSummary = ThisWorkbook.Worksheets("Summary")
    Set rgBooks = ThisWorkbook.Sheets("WB Names").Range("A1").CurrentRegion
    Set rgFiles = Intersect(rgBooks, rgBooks.Offset(1))
    Application.ScreenUpdating = False
    shSummary.UsedRange.Offset(1).Clear
    On Error Resume Next
    For Each rgC In rgFiles.Cells
        sFileName = rgC.Value
        Set wb = Workbooks.Open(sPath & sFileName)
        If Not wb Is Nothing Then
            For Each sh In wb.Sheets
                If sh.Visible = xlSheetVisible And (InStr(1, UCase(sh.Name), "AO") > 0 Or InStr(1, UCase(sh.Name), "GO") > 0) Then
                    Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy
                    shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End If
            Next sh
            Application.CutCopyMode = False
            wb.Close SaveChanges:=False
        End If
        Set wb = Nothing
        sFileName = ""
    Next rgC
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

[Rudi]

TX Hans...
LOL... I was about to paste the updated code when I saw your post come through.

Joe, as Hans has mentioned, there are hidden sheets in your source file that contain AO or GO in the sheet name. The macro was processing these sheets as they meet the conditions to process. Its these sheets that produced the blank blocks, since there is no data in it, besides the ID #'s. Hans (in his code) has now added a condition to not process these hidden sheets.

[JoeExcelHelp]

Bth of you, Thank You, I failed to check hidden sheets.. really a simple oversight on my end.. sorry for the inconvenience

[JoeExcelHelp]

This is more for my own knowledge.. when I ran this code I kept getting a clipboard size information alert and I know its directly related to the copy paste portion of the code
so I researched this and found a work around by inserting "Application.DisplayAlerts = False"
It seems to work but I figure why not ask the pro's if what I inserted is correct :)

Code: Select all

Sub MergeSelectedWorkbooks2()
Dim shSummary As Worksheet
Dim rgFiles As Range
Dim rgC As Range
Dim sFileName As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCnt As Long
Dim sMsg As String

Const sPath = "C:\Users\gg70397\Tracing\Documents\" ' << Change path as needed...
    
    lCnt = 0
    Set shSummary = ThisWorkbook.Worksheets("Summary")
    Set rgBooks = ThisWorkbook.Sheets("WB Names").Range("A1").CurrentRegion
    Set rgFiles = Intersect(rgBooks, rgBooks.Offset(1))
    'If rgFiles Is Nothing Then
        'MsgBox "No files were listed on the 'WB Names' sheet!" & vbNewLine & _
            '"The macro will now quit.", vbExclamation
        'Application.ScreenUpdating = True
        'Exit Sub
    'End If
    Application.ScreenUpdating = False
    rgFiles.Interior.Color = xlNone
    shSummary.UsedRange.Offset(1).Clear
    On Error Resume Next
    For Each rgC In rgFiles.Cells
        sFileName = rgC.Value
        Set wb = Workbooks.Open(sPath & sFileName)
        If Not wb Is Nothing Then
            For Each sh In wb.Sheets
                If InStr(1, UCase(sh.Name), "AO") > 0 Or InStr(1, UCase(sh.Name), "GO") > 0 Then
                     Intersect(sh.Range("A1").CurrentRegion, sh.Range("A1").CurrentRegion.Offset(1)).Copy
                    shSummary.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    Application.DisplayAlerts = False
                End If
            Next sh
            wb.Close SaveChanges:=False
        'Else
            'rgC.Interior.Color = vbRed
            'lCnt = lCnt + 1
        End If
        Set wb = Nothing
        sFileName = ""
    Next rgC
    On Error GoTo 0
    'shSummary.Columns.AutoFit
    Application.ScreenUpdating = True
    
    'If lCnt > 0 Then
        'sMsg = "The macro completed its run, but some (or all) files were not found! " & _
                '"Files not found are marked in red on the 'WB Names' sheet."
        ''MsgBox sMsg, vbExclamation
    'Else
        'sMsg = "Data from all files collected."
        'MsgBox sMsg, vbInformation
    'End If
End Sub

[Rudi]

Hi Joe,

The statement you refer to is indeed the one to suppress warning messages. As long as it is executed before the event that triggers the warning, it will work, so there is no hard rule on where to place it in the code. You have it inside the loop procedure, and although its not detrimental to the procedure, a better place to put it is just before the line: wb.Close SaveChanges:=False.

Under normal scenarios, one could place it up at the top of the macro if one knows there might be a number of alerts during the course of the macro, like deleting sheets, etc...

[HansV]

If you look at the code that I posted, you'll see that I included

Code: Select all

            Application.CutCopyMode = False

just above

Code: Select all

            wb.Close SaveChanges:=False

so I had anticipated your problem...

[JoeExcelHelp]

lol.. Thanks Hans