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.

 

[30136353]

Merged cells almost always cause problems for macros and should be avoided at all cost. The merged cells would have to be unmerged. That can be done manually or the macro can do it for you. Please advise.

The macro will be able to do it as the sheets which are merged are not of value anyway... Thanks

 

[mumps]

Try:

Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim MyFolder As String, MyFile As String, wkbSource As Workbook, wsDest As Worksheet, x As Long, LastRow As Long
    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 3
            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
        Next x
        MyFile = Dir
        wkbSource.Close False
    Loop
    Application.ScreenUpdating = True
End Sub

 

[30136353]

Try:

Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim MyFolder As String, MyFile As String, wkbSource As Workbook, wsDest As Worksheet, x As Long, LastRow As Long
    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 3
            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
        Next x
        MyFile = Dir
        wkbSource.Close False
    Loop
    Application.ScreenUpdating = True
End Sub

Still the same error unfortunately

 

[mumps]

Unless you can upload a copy of the problem workbook, I'm afraid I won't be able to help any further.

 

[30136353]

Unless you can upload a copy of the problem workbook, I'm afraid I won't be able to help any further.

Managed to create the drop box on my phone. On the first workbook i am after all info from sheet 1 and 2. On the 2nd workbook with survey in the name i am only after sheet 3 named address.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[mumps]

We still have a few problems. In the second workbook the "Address" sheet is protected. Secondly, you want 2 sheets from one workbook and only one sheet from the other. Unless the number of sheets is the same for all workbooks, that complicates matters because you would have to call the sheets by their names. This means that you would need a list of the actual workbook names and the names of the sheets you want in each workbook.

 

[30136353]

We still have a few problems. In the second workbook the "Address" sheet is protected. Secondly, you want 2 sheets from one workbook and only one sheet from the other. Unless the number of sheets is the same for all workbooks, that complicates matters because you would have to call the sheets by their names. This means that you would need a list of the actual workbook names and the names of the sheets you want in each workbook.

I am happy for the first 3 sheets to be taken from all workbooks, as it wont matter if i have excess data, i will be using formulas to look into the new master sheet. Can the macro unlock the workbooks before processing?

 

[mumps]

I would need to know the password. Hopefully, the password is the same for all the sheets. If it's different, I'm afraid I will not be able to help.

 

[30136353]

I would need to know the password. Hopefully, the password is the same for all the sheets. If it's different, I'm afraid I will not be able to help.

Ill find out tomorrow ans get back to you. Thanks

 

[30136353]

I would need to know the password. Hopefully, the password is the same for all the sheets. If it's different, I'm afraid I will not be able to help.

Mumps, thanks for all your help. I've actually just decided to use the merge for only the sheets without passwords, ive managed to change a few formulas to get all the information I was after. Regarding this piece of code, is there a way to tell it if no sheet 2 exists, just to skip it and not give an error?

Thanks:

Do While MyFile <> ""
        Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
        For x = 1 To 2
            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(0, 0)
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
                End With
            End If
        Next x
        MyFile = Dir
        wkbSource.Close False
    Loop