Results 1 to 5 of 5

Thread: Consolidate multiple workbooks from a folder into one master file VBA

  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10

    Lightbulb Consolidate multiple workbooks from a folder into one master file VBA

    Hi All,

    Here is sub which will consolidate multiple workbooks from a single folder into a master workbook.

    It even handles the different col headers while consolidating.

    Code:
    Dim dic             As Object
    Dim Counter         As Long
    Sub ConsolidateWorkbooks()
        
        Dim r           As Long
        Dim c           As Long
        Dim n           As Long
        Dim j           As Long
        Dim Fldr        As String
        Dim Fname       As String
        Dim wbkActive   As Workbook
        Dim wbkSource   As Workbook
        Dim Dest        As Range
        Dim d, k()
        
        '// User settings
        Const SourceFileType        As String = "xls*"  'xls,xlsx,xlsb,xlsm
        Const DestinationSheet      As String = "Sheet1"
        Const DestStartCell         As String = "A1"
        Const MaxRows               As Long = 50000
        Const MaxCols               As Long = 100
        Const StartRow              As Long = 2
        '// End
        
        Application.ScreenUpdating = False
        Counter = 0
        With Application.FileDialog(4)
            .Title = "Select source file folder"
            .AllowMultiSelect = False
            If .Show = -1 Then
                Fldr = .SelectedItems(1)
            Else
                GoTo Xit
            End If
        End With
        
        
        Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
        
        Set wbkActive = ThisWorkbook
        
        ReDim k(1 To MaxRows, 1 To MaxCols)
        
        Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestStartCell)
        
        Fname = Dir(Fldr & "\*." & SourceFileType)
        
        Do While Len(Fname)
            If wbkActive.Name <> Fname Then
                Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
                With wbkSource.Worksheets(1)
                    d = .Range("a1").CurrentRegion
                    UniqueHeaders Application.Index(d, 1, 0)
                    For r = StartRow To UBound(d, 1)
                        If Len(d(r, 1)) Then
                            n = n + 1
                            For c = 1 To UBound(d, 2)
                                If Len(Trim$(d(1, c))) Then
                                    j = dic.Item(Trim$(d(1, c)))
                                    k(n, j) = d(r, c)
                                End If
                            Next
                        End If
                    Next
                    Erase d
                End With
                wbkSource.Close 0
                Set wbkSource = Nothing
            End If
            Fname = Dir()
        Loop
        
        If n Then
            Dest.Resize(, dic.Count) = dic.keys
            Dest.Offset(1).Resize(n, dic.Count) = k
            MsgBox "Done", vbInformation, "ExcelFox.com"
        End If
    Xit:
        Application.ScreenUpdating = True
        
    End Sub
    Private Sub UniqueHeaders(ByRef DataHeader)
        
        Dim i   As Long
        Dim j   As Long
        
        With Application
            j = .ScreenUpdating
            .ScreenUpdating = False
        End With
        
        For i = LBound(DataHeader) To UBound(DataHeader)
            If Len(Trim$(DataHeader(i))) Then
                If Not dic.exists(Trim$(DataHeader(i))) Then
                    Counter = Counter + 1
                    dic.Add Trim$(DataHeader(i)), Counter
                End If
            End If
        Next
        
        Application.ScreenUpdating = j
        
    End Sub
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  2. #2
    Junior Member
    Join Date
    Feb 2013
    Posts
    2
    Rep Power
    0

    Specific folder

    I have been searching quite a while for such a code. And this one appears to be perfect, thanks a lot!

    Nevertheless I am now looking to change it to a defined folder. Meaning that I'd like to drop the part which allows you to browse to select a folder and instead specify the folder address directly in the code.

    Since I am not a very advanced VBA user I don't know how I should handle it since the code is verry condensed.
    Thanks for your help.

  3. #3
    Junior Member
    Join Date
    Dec 2012
    Posts
    3
    Rep Power
    0
    Replace
    Code:
        With Application.FileDialog(4)
            .Title = "Select source file folder"
            .AllowMultiSelect = False
            If .Show = -1 Then
                Fldr = .SelectedItems(1)
            Else
                GoTo Xit
            End If
        End With
    With
    Code:
    Fldr = "C:\SubFolder\MyFolder" 'change to the desired location
    AK

  4. #4
    Junior Member
    Join Date
    Feb 2013
    Posts
    2
    Rep Power
    0
    Thanks for the help.

    I am now stuck again because I had to modifiy the document layout.
    Is there a way to make this code handle the number of columns that should be considered?
    I would like to limit the data to columns "A to S" in other words the 19 first columns.
    I tried to tweak "MaxCols" but it doesn't work.

    Could anyone give me a hint on this please?

    Thanks in advance!

  5. #5
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi

    Untested. Replace
    Code:
    d = .Range("a1").CurrentRegion
    with

    Code:
    d = .Range("a1").CurrentRegion.resize(,19).value
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

Similar Threads

  1. Replies: 1
    Last Post: 06-07-2013, 10:32 AM
  2. Replies: 2
    Last Post: 05-28-2013, 05:32 PM
  3. Replies: 7
    Last Post: 05-09-2013, 11:16 PM
  4. Replies: 2
    Last Post: 12-19-2012, 08:28 AM

Tags for this Thread

Posting Permissions

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