VBA - Combine Multiple workbooks into 1 worksheet

[30136353]

Hi,

I am trying to write a VBA script which will combine multiple workbooks into 1 worksheet, copy and pasting all columns as values. Each sheet from the multiple workbooks should be pasted below the last, and ideally there would be the workbook name pasted into column A of the master as a unique identifier. The multiple workbooks would be stored in a folder on my desktop, but id like the macro to pop up and allow me to browse and select the folder.... I have seen a lot online but not quite what I'm after, any help? Thanks.

 

[mumps]

Are the sheets named "Sheet1" and "Sheet2"?

 

[30136353]

No, they'll have unique names...

 

[mumps]

If you are looping through 2 sheets (For x = 1 to 2) , this macro should work only if Sheet2, if it exists, is either the first or second sheet in the workbook. If you are looping through 5 sheets (For x = 1 to 5), Sheet2, if it exists, must among the first 5 sheets in your workbook. If Sheet2 exists and is outside the looped sheets, the macro will not work properly.

Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim MyFolder As String, MyFile As String, wkbSource As Workbook, wsDest As Worksheet, x As Long, LastRow As Long, ws As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
        For x = 1 To 2
            On Error Resume Next
            Set ws = Sheets(x)
            On Error GoTo 0
            If ws.CodeName = "Sheet2" Then
                If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
                    With Sheets(x)
                        .Cells.UnMerge
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    End With
                    With wsDest
                        Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
                    End With
                End If
            Else
                If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
                    With Sheets(x)
                        .Cells.UnMerge
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    End With
                    With wsDest
                        Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
                    End With
                End If
            End If
        Next x
        MyFile = Dir
        wkbSource.Close False
    Loop
    Application.ScreenUpdating = True
End Sub

 

[30136353]

If you are looping through 2 sheets (For x = 1 to 2) , this macro should work only if Sheet2, if it exists, is either the first or second sheet in the workbook. If you are looping through 5 sheets (For x = 1 to 5), Sheet2, if it exists, must among the first 5 sheets in your workbook. If Sheet2 exists and is outside the looped sheets, the macro will not work properly.

Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim MyFolder As String, MyFile As String, wkbSource As Workbook, wsDest As Worksheet, x As Long, LastRow As Long, ws As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
        For x = 1 To 2
            On Error Resume Next
            Set ws = Sheets(x)
            On Error GoTo 0
            If ws.CodeName = "Sheet2" Then
                If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
                    With Sheets(x)
                        .Cells.UnMerge
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    End With
                    With wsDest
                        Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
                    End With
                End If
            Else
                If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
                    With Sheets(x)
                        .Cells.UnMerge
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    End With
                    With wsDest
                        Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
                    End With
                End If
            End If
        Next x
        MyFile = Dir
        wkbSource.Close False
    Loop
    Application.ScreenUpdating = True
End Sub

Is there a way to have 3 unique sheet names?

 

[mumps]

Are you saying that you want to loop through 3 specific sheets? If so, what are the names of the sheets?

 

[30136353]

Are you saying that you want to loop through 3 specific sheets? If so, what are the names of the sheets?

Yes correct, i only need 3 sheets from the workbooks which always have the same name. They are 3 constant names, lets say "123" "456" and "789"...