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]

Do you have a question?

 

[30136353]

Ill see if I can upload a oducment when home. I removed the word text box, removed all passwords and deleted the validation from the sheet thinking one of them may be the issue, but still no luck. In Range A1 to M50 there are some columns within the sheet which are fully blank, not sure if this is cuasing the problem

 

[mumps]

removed all passwords

Are any of the sheets protected?

 

[30136353]

Are any of the sheets protected?

They are normally but ive took all the protections off to trial it and still getting the same issue

 

[30136353]

ahhhh the workbook is still protected even after I have remove passwords from the individual sheets. I also think the problem is sheet 2 is completely blank, probably causing the error. I would need a method to select only sheets with certain names... The workbook being protected must not be an issue as the macro works fine with sheet 1 from it which has text on it. It seems to be breaking at sheet 2 which is blank. Thanks for the help

 

[mumps]

Are you OK with the macro as is or do you need any more help?

 

[30136353]

Are you OK with the macro as is or do you need any more help?

I still need the last issue fixed. Sheet 2 will be blank on some documents, so i either need to be able to specify actual sheet names or just have the macro combine sheet 1, 2 and 3 even if sheet 2 on some workbooks will be blank...

 

[mumps]

The macro below will ignore any sheet that is totally blank.

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
                LastRow = Sheets(x).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                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]

The macro below will ignore any sheet that is totally blank.

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
                LastRow = Sheets(x).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                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

Seemed to get past the last problem, although now I have a run time error 1004, cannot change part of a merged cell. There are merged cells on some of the sheets which is unavoidable...

 

[mumps]

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.