VBA merge workbooks in a folder

Question

I need to merge all workbooks in a folder to one file, specifications i'm looking is my folder is dynamic so i need a folder picker for the code. Next thing each workbook in the folder has multiple sheets, i need to consolidate only the sheets with name ("report"). Also the data starts from Range ("A7"). it also contains formulas in the individual sheets, so there should not be formula error after combining.

can somebody help?

Sub GetWorkbook()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Path = ThisWorkbook.Path & "\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
ActiveSheet.AutoFilterMode = False
Sheets("Report").Copy After:=ThisWorkbook.Sheets(1)
Range("1:6").EntireRow.Hidden = True
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.DisplayAlerts = True
Combine
Sheets("Home").Select
MsgBox ("Data Consolidated"), vbInformation

End Sub


Function combine
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Combined" And ws.Name <> "Home" Then
ws.Activate
Dim LastRowW As Long
LastRowW = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("A7:P" & LastRowW).Copy 
Sheets("Combined").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial (xlPasteValues)
ws.Delete
End If
Next ws

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Function

Here is the code, I have mainly 2 worksheets in the macro workbook (combined and home). The second is a function is to copy the details to the combined sheets and delete the other workbooks. This will work only if all the workbooks are saved in the (this workbook path). How to enable a folder picker to consolidate the files in selected folder.

Answer 1

Consider this option. There are four basic examples, 3 on this page and 4 in the example workbook: 1) Merge a range from all workbooks in a folder (below each other) 2) Merge a range from every workbook you select (below each other) 3) Merge a range from all workbooks in a folder (next to each other) 4) Merge a range from all workbooks in a folder with AutoFilter

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            On Error Resume Next

            With mybook.Worksheets(1)
                Set sourceRange = .Range("A1:C1")
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else
                'if SourceRange use all columns then skip this file
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    'Copy the file name in column A
                    With sourceRange
                        BaseWks.cells(rnum, "A"). _
                                Resize(.Rows.Count).Value = MyFiles(Fnum)
                    End With

                    'Set the destrange
                    Set destrange = BaseWks.Range("B" & rnum)

                    'we copy the values from the sourceRange to the destrange
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next Fnum
    BaseWks.Columns.AutoFit
End If

ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub

https://www.rondebruin.nl/win/s3/win008.htm

As an alternative, I would highly recommend this AddIn.

https://www.rondebruin.nl/win/addins/rdbmerge.htm