Results 1 to 2 of 2

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

  1. #1
    Junior Member
    Join Date
    Jun 2013
    Posts
    1
    Rep Power
    0

    Consolidate multiple workbooks from a folder into one master file VBA

    I'm trying to use the vba code in Consolidate multiple workbooks from a folder into one master file VBA (below)

    attached is an example spreadsheet that the code hangs on

    and I get a type mismatch when the code tries to run:

    Code:
              UniqueHeaders Application.Index(d, 1, 0)
    Thanks in advance for any help.


    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
    Attached Files Attached Files

  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,122
    Rep Power
    10
    Last edited by DocAElstein; 07-09-2023 at 11:03 PM.
    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: 2
    Last Post: 05-28-2013, 05:32 PM
  2. Replies: 7
    Last Post: 05-09-2013, 11:16 PM
  3. Consolidate multiple workbooks from a folder into one master file VBA
    By Admin in forum Excel and VBA Tips and Tricks
    Replies: 4
    Last Post: 02-26-2013, 09:00 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
  •