Meger multiple file but header not same

[rocky]

Hi

I want to consolidated the multiple exel files from folder but header of excel files in folder is different and this macro showing error.
I will be thankful to you if you provide me the modify macro. I am new to macro.

i

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.

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

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

[Admin]

Hi rocky,

Welcome to ExcelFox!!

Please explain what kind of error you got and at which line ?

[rocky]

Hi

The error I getting is

Run-time error '13'
Type mismatch

When I click on debug the following line getting an error.

UniqueHeaders Application.Index(d, 1, 0)

However I have identify that header in some of excel sheet is not same but I need to consolidated the data from all workbook. Please help me.

Hi rocky,

Welcome to ExcelFox!!

Please explain what kind of error you got and at which line ?

[Admin]

If it's not in the first row, how we can identify that in which row the header is ?

In the meantime place these line above the error line.

Do While Application.WorksheetFunction.CountA(.Rows(1)) = 0
    .Rows(1).Delete
Loop

[rocky]

The header is in the first row of all workbook but heading is different in some of workbook.
I have pasted updated line of coding but again getting following error:-


Runt-time error '9'
subcript out of range

Below is line of error

k(n, j) = d(r, c)

If it's not in the first row, how we can identify that in which row the header is ?

In the meantime place these line above the error line.

Do While Application.WorksheetFunction.CountA(.Rows(1)) = 0
    .Rows(1).Delete
Loop

[Admin]

before the error line write

debug.print j

and see what is the number in the immediate window (Ctrl + G) when the error comes in.

[rocky]

Answer is 0

before the error line write

debug.print j

and see what is the number in the immediate window (Ctrl + G) when the error comes in.

[Admin]

Any chance to see your workbooks ?

You can upload the workbooks by clicking 'Go Advanced' and then 'manage attachments'

[rocky]

I cannot upload the file. Can you modify the macro coding so that I can copy data from all workbook in folder range A2:AS2 to end of the row.(copy the data without header)


You can upload the workbooks by clicking 'Go Advanced' and then 'manage attachments'[/QUOTE]

[Admin]

Hi

Try

Option Explicit

Sub ConsolidateWorkbooks()
    
    Dim j           As Long
    Dim Fldr        As String
    Dim Fname       As String
    Dim wbkActive   As Workbook
    Dim wbkSource   As Workbook
    Dim Dest        As Range
    
    '// User settings
    Const SourceFileType        As String = "xls*"  'xls,xlsx,xlsb,xlsm
    Const DestinationSheet      As String = "Sheet1"
    Const DestStartCell         As String = "A1"
    Const StartRow              As Long = 2
    '// End
    
    Application.ScreenUpdating = False
    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 wbkActive = ThisWorkbook
    
    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)
                j = .Range("a" & .Rows.Count).End(3).Row
                .Range("a2:as" & j).Copy Dest
                Set Dest = Dest.Offset(j)
            End With
            wbkSource.Close 0
            Set wbkSource = Nothing
        End If
        Fname = Dir()
    Loop
    
Xit:
    Application.ScreenUpdating = True
    
End Sub