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(DestS tartCell)

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 (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(DestS tartCell)

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

[rocky]

Thanks buddy, now it is working....

[rocky]

Hi

I have run this macro and it is working fine. But there is blank row coming in consolidated sheet after sheet data. For example one workbook data is pasted in consolidated sheet and then one row left blank. Then second workbook data is pasted and then one row blank. There thirty row leave blank because thirty file to consolidate.

Seondly the formating of sheet is not proper way. Is there any way to consolidate the data as value so that cell size does not change.


Thanks buddy, now it is working....

[Admin]

Hi

After the line 'Loop' insert the following line.


dest.EntireColumn.SpecialCells(4).EntireRow.Delete

also replace this line


.Range("a2:as" & j).Copy Dest

with


.Range("a2:as" & j).Copy
dest.PasteSpecial -4163
dest.PasteSpecial -4122

[rocky]

Hi

I am getting the following error again and again

There is large amount of information on the Clipboard. Do you want to be able to paste this information into another programe later.

To save it on the Clipboard so that you can paste it later, click Yes
To delete if from the Clipboard and free memory, click no.

[Admin]

Don't quote the replies.

add this line

Application.CutCopyMode = False

before this line

wbkSource.Close 0