Meger multiple file but header not same
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
Quote:
Originally Posted by
Admin
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
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Meger multiple file but header not same
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.
Quote:
Originally Posted by
Admin
Hi rocky,
Welcome to ExcelFox!!
Please explain what kind of error you got and at which line ?
Meger multiple file but header not same
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)
Quote:
Originally Posted by
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.
Code:
Do While Application.WorksheetFunction.CountA(.Rows(1)) = 0
.Rows(1).Delete
Loop
Meger multiple file but header not same
Answer is 0
Quote:
Originally Posted by
Admin
before the error line write
and see what is the number in the immediate window (Ctrl + G) when the error comes in.
Mege multiple file but header not same
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]
