Consulting

Results 1 to 10 of 10

Thread: VBA to merge multiple workbooks with demarcation

  1. #1
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location

    VBA to merge multiple workbooks with demarcation

    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 not able to know where one workbook data starts and ends. And I need that knowledge to be able to proceed with further analysis.

    Sub Button2_Click()
    
    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    
    ThisWB = ActiveWorkbook.Name
    
    path = GetDirectory("Select a folder containing Excel files you want to merge")
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set shtDest = ActiveWorkbook.Sheets(1)
    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 CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
    Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy Dest
    Wkb.Close False
    End If
    
    Filename = Dir()
    Loop
    
    Range("A1").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
    End Sub
    Thanks alot
    Last edited by Bob Phillips; 06-08-2021 at 06:54 AM. Reason: Added code tags

  2. #2
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    With Wkb.Sheets(1).UsedRange
        Set CopyRng = Intersect(.Cells, .Offset(RowofCopySheet - 1))
    End With
    Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    Dest.Resize(CopyRng .Rows.Count).Value = Filename
    CopyRng.Copy Dest.Offset(, 1)

  3. #3
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location
    Thanks alot. I will try it and get back.

  4. #4
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location
    Pls the expert, I am to use this script together with my own. I mean the one that merge multiple workbooks into single one. Or it use it alone.
    It is as if I am not getting it. Thanks

  5. #5
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  6. #6
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location
    [QUOTE=Bob Phillips;409868][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


    Pls expert, can you help me check this code again. It is not running at all. I will click run, it will just fail to run and not doing anything. You yourself can try it. Thanks

  7. #7
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location
    Pls expert, can you help me check this code again. It is not running at all. I will click run, it will just fail to run and not doing anything. You yourself can try it. Thanks

  8. #8
    VBAX Regular
    Joined
    Jun 2021
    Posts
    19
    Location
    Pls, there is compile error: Label not defined
    Thanks

  9. #9
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    Sorry, my error

    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
    
    err_exit:
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    @akin

    Have you got any VBA knowledge ?

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •