VBA to merge multiple workbooks with demarcation

akin · Jun 10th 2021

Pls, I need help on how to merge multiple excel workbooks into single worksheet but with demarcation. I mean I want to know where one workbook data starts and ends, preferably filling the entire first column with workbook name.

What this mean is that as each workbook is copying to the new worksheet, it will pick its workbook name and use it to fill entire first column in the new worksheet and do that to all workbooks.
I had tried the code below before but I was giving me 'compile error: Label not define' . I want to know what is wrong with the code. Or preferably a new one.

Code

Sub Button2_Click()
Dim Wkb As Workbook
Dim wbDest As Workbook, shtDest As Worksheet, source As Worksheet
Dim path As String, ThisWB As String, Filename As String
Dim CopyRng As Range, Dest As Range
Dim currLastrow As Long, prevlastrow As Long        On Error GoTo err_exit    Application.EnableEvents = False    Application.ScreenUpdating = False
    currLastrow = 2 ' Row to start on in the sheets you are copying from        ThisWB = ActiveWorkbook.Name    Set shtDest = ActiveWorkbook.Sheets(1)        path = GetDirectory("Select a folder containing Excel files you want to merge")        Filename = Dir(path & "\*.xls", vbNormal)    If Len(Filename) = 0 Then Exit Sub        Do Until Filename = vbNullString            If Not Filename = ThisWB Then                    Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)            Set source = Wkb.Sheets(1)            Set CopyRng = source.Range(source.Cells(currLastrow, 1), source.Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))                        Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)            CopyRng.Copy Dest                        Wkb.Close False                        prevlastrow = currLastrow            currLastrow = shtDest.Cells(shdest.Rows.Count, "B").End(xlUp).Row            shdest.Cells(prevlastrow, "A").Resize(currLastrow - prevlastrow + 1).Value = Filename        End If                Filename = Dir()    Loop        shdest.Range("A1").Select        Application.EnableEvents = True    Application.ScreenUpdating = True        MsgBox "Done!"        Exit Sub

GoTo err_exit:    Application.EnableEvents = True    Application.ScreenUpdating = True
End Sub

Thanks a lot.

Mumps · Jun 10th 2021

Could you attach a copy of your destination file including any macros and at least one of the source files? It would be easier to see how your data is organized and to test possible solutions. Include a detailed explanation of what you want to do using a few examples from your data and referring to specific cells, rows, columns and sheets. De-sensitize the data if necessary.

akin · Jun 10th 2021

Thanks

Each file is like these ones

AAWW.xlsm ABNB.xlsm

Mumps · Jun 10th 2021

Place this macro in your destination workbook:

Code

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wsDest As Worksheet, wkbSource As Workbook, FolderName As String, lRow As Long
    Set wkbDest = ThisWorkbook
    Set wsDest = ThisWorkbook.Sheets(1)
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strextension = Dir("*.xls*")
    Do While strextension <> ""
        If wkbDest.Name <> strextension Then
            Set wkbSource = Workbooks.Open(FolderName & strextension)
            With wkbSource
                 lRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Sheets(1).UsedRange.Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 1) = wkbSource.Name
                .Close False
            End With
        End If
        strextension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Display More

akin · Jun 10th 2021

Thanks.

Let me try it.

akin · Jun 10th 2021

Thanks alot. It worked perfectly.

Sorry for this. I have a slight problem; I first used it with my sample folder that contain just 4 workbooks and it worked, but when I wanted to use it with the real folder containing 380 workbooks it failed to work. It did not respond at all. Please what could be responsible? Thanks

Mumps · Jun 10th 2021

Try stepping through the macro one line of code at a time. Place the cursor anywhere in the macro and press the F8 key repeatedly. We’re any of the source workbooks opened? We’re any errors generated?

akin · Jun 11th 2021

Thanks

When I tried that. Meaning, when I was pressing F8 repeating and the lines got to 'FolderName=. SelectedItem(1)&"\" ' it tried to open source folder. And when I picked it, it failed to performed any function. There was no error generated and it stopped there. I mean the F8 refused to go pass there. Thanks alot.

Mumps · Jun 11th 2021

If the macro worked with the sample folder, I don't understand why it wouldn't work with the real folder. The number of source files should not effect how the macro works. Try copying the real files into your sample folder and give it another try.

VBA to merge multiple workbooks with demarcation

Participate now!

Share