VBA Code Require - Consolidate multiple sheets in 1 sheet when column Headin differs

[Yadavagiri]

Hi Team,

VBA Code required to consolidate multiple sheets into one consolidated sheet when the column heading is different.

Attached sample raw data where I need VBA code consolidate data from all the sheets into one sheet matching with the EIN and data against the column heading from all the sheets.

Kindly let me know for any clarifications.

Regards,
Yadavagiri

[p45cal]

In the linked-to file below, 2 new sheets added:
Consolidated: what it says on the tin: where possible columns merged, where not, just added as new columns.
Pivot: The beginnings of a pivot table of the consolidated sheet.

Power Query has consolidated the sheets. For you to use different data, update the information in the 6 tables, refresh the query called Consolidate (right-click the Consolidated table and choose Refresh) and refresh the pivot table.

That's it.

link to big file:
https://app.box.com/s/60mpxqpwlin82q9bdx8b6ecypb5mwe72

ps. the file size could be reduced by loading the consolidated date to the Data Model rather than the Consolidated sheet which would reduce the file size to less that two thirds.

[p45cal]

I've beeen playing about with Power Query (I don't know what I'm doing) and managed to reduce the file size even more to where it's only 6% bigger than your file, and so can attach it here. You can't see the consolidated data because it doesn't exist on a sheet, but the pivot table connects to it. Now it appears you only need to refresh the pivot table, and it seems to be quicker too.

[mana]

Option Explicit


Sub test()
Dim dic As Object
Dim ws As Worksheet
Dim v, w()
Dim j As Long, k As Long
Dim s As String
Dim m As Long, n As Long

Set dic = CreateObject("scripting.dictionary")

ReDim w(1 To Rows.Count, 1 To 100)

For Each ws In Worksheets
v = ws.Cells(1).CurrentRegion.Value
For j = 1 To UBound(v, 1)
s = v(j, 1) & v(j, 2) & v(j, 3) & v(j, 4)
If Not dic.exists(s) Then
n = dic.Count + 1
dic(s) = n
w(n, 1) = v(j, 1)
w(n, 2) = v(j, 2)
w(n, 3) = v(j, 3)
w(n, 4) = v(j, 4)
End If
n = dic(s)
For k = 5 To UBound(v, 2)
w(n, k + m) = v(j, k)
Next
Next
m = m + UBound(v, 2) - 4
Next

With Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1)
.Resize(dic.Count, m - 1).Value = w
.CurrentRegion.Sort .Columns(3), Header:=xlYes
End With

End Sub



マナ

[Yadavagiri]

Hi Mana,

Thanks for VBA Code,when I run the code, I am getting error. Attached error screenshot. please do the needful and let me now what needs to be done.

Regards,
Yadavagiri

[Yadavagiri]

Hi,

I don't have power query enabled in my system as it doesn't support :( Any possible for getting VBA Code?

Regards,
YadavagirI

[mana]

try this





'ReDim w(1 To Rows.Count, 1 To 100)


Dim x As Long, y As Long


For Each ws In Worksheets
x = x + ws.Cells(1).End(xlToRight).Column
y = y + ws.Cells(1).End(xlDown).Row
Next
ReDim w(1 To y, 1 To x)

[Yadavagiri]

Hi Mana,

I am very sorry to come back as im little bad at VBA. Where do I input this code?

Regards,
Yadavagiri

[mana]

Instead of this line.

> ReDim w(1 To Rows.Count, 1 To 100)

[Yadavagiri]

Hi Mana,

I tried replacing, however, got error. Enclosed Screenshot.

I have attached my sample excel file. Please could you help on the same.

Regards,
Yadavagiri

[Yadavagiri]

Hi Mana,

I thank you for assisting which is very much appreciated.

your code with the above changes was success and it worked, however, if I add any additional column data in any of the sheets and also if any new sheets are added in the workbook, it is not working.

please help!

Regards,
Yadavagiri

[mana]

>it is not working

What do you mean?
Error occurs?

[Yadavagiri]

Hi Mana,

Thanks for getting back.

I meant to say that, if I add any additional column, the data is not capturing. Also, if I add any additional sheet, it is not updating.

Attached file, Consolidated Sheet is the sheet which I have worked from your code.

Sheet highlighted in Orange in the attached, where the data has captured only one column (Work) remaining data in column F & G is not captured in the Consolidated Sheet.

Also no data is captured from sheet highlighted in Red (Hold).

Kindly help.

Regards,
Yadavagiri

[mana]

It's not automatic,
you have to run again.

[Yadavagiri]

Hi Mana,

Yes I have ran the code again but its the same as above.

Regards,
Yadavagiri

[mana]

.Resize(dic.Count, m + 4).Value = w

[Yadavagiri]

Hi Mana,

Sorry to revert back so late.
I have amended the changes which is perfectly working fine for my current set of data.

however, I have another set of data where there are multiple column headers and when I update this code and run, it throws out error.

Please help me with a VBA Code where the code will run even though there are multiple column headers.

Regards,
Yadavagiri

[mana]

however, I have another set of data where there are multiple column headers and when I update this code and run, it throws out error.



I need sample data.
Please upload your workbook.

[Yadavagiri]

Hi Mana,

File size is around 4mb and I am unable to upload. :( Do you have email id so that i can forward you?

Regards,
Yadavagiri

[snb]

@mana

Use advancedfilter.

[mana]

I can't understand the meaning of "multiple column headers"
So, I need small data, not full data.

[Yadavagiri]

Hi Mana,

I am unable to attach the file despite deleting most of the data as size is not reducing to require sample size.

I believe the failure is not because of columns, it is because of number of row items in each sheet.

When I consolidate manually all the sheets into one, it is able to accommodate all rows of all sheets, but this through VBA Code, it is not able to.

Can you suggests change in VBA Code for this?

Regards,
Yadavagiri

[mana]

Sub test2()
Dim dic As Object
Dim myWb As Workbook
Dim rngDst As Range
Dim ws As Worksheet
Dim v, w()
Dim j As Long, k As Long
Dim s As String
Dim n As Long

Set dic = CreateObject("scripting.dictionary")

Set myWb = ActiveWorkbook
Set rngDst = Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1)

For Each ws In myWb.Worksheets
v = ws.Cells(1).CurrentRegion.Resize(, 4).Value
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & v(j, 3) & vbTab & v(j, 4)
If Not dic.exists(s) Then dic(s) = dic.Count + 1
Next
Next

rngDst.Resize(dic.Count).Value = Application.Transpose(dic.keys)
rngDst.CurrentRegion.TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False

For Each ws In myWb.Worksheets
v = ws.Cells(1).CurrentRegion.Value
ReDim w(1 To dic.Count, 1 To UBound(v, 2) - 4)
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & v(j, 3) & vbTab & v(j, 4)
n = dic(s)
For k = 5 To UBound(v, 2)
w(n, k - 4) = v(j, k)
Next
Next
Set rngDst = rngDst.End(xlToRight).Offset(, 1)
rngDst.Resize(UBound(w, 1), UBound(w, 2)).Value = w
Next

rngDst.CurrentRegion.Sort rngDst.Cells(3), Header:=xlYes


End Sub

[Yadavagiri]

Hi Mana,

Thank you for your response.

Wow, This worked really well. This is outstanding.

However, there is one glitch. Date column in the Consolidated sheet is showing incorrect for few dates. For Ex: Actual Date in the sheets is 01/04/2019, however, in the Consolidated sheets, its showing as 04/01/2019 and look up value for these dates in consolidated sheets is showing incorrect. Can this be amended accordingly in such a way that it takes the date as shown in the sheets?

If this is amended, then the code will be perfect and good to use

Regards,
Yadavagiri

[mana]

Sub test3()
Dim dic As Object
Dim myWb As Workbook
Dim rngDst As Range
Dim ws As Worksheet
Dim v, w()
Dim j As Long, k As Long
Dim s As String
Dim n As Long

Set dic = CreateObject("scripting.dictionary")

Set myWb = ActiveWorkbook
Set rngDst = Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1)

For Each ws In myWb.Worksheets
v = ws.Cells(1).CurrentRegion.Resize(, 4).Value
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & Format(v(j, 3), "d-mmm-yy") & vbTab & v(j, 4)
If Not dic.exists(s) Then dic(s) = dic.Count + 1
Next
Next

rngDst.Resize(dic.Count).Value = Application.Transpose(dic.keys)
rngDst.CurrentRegion.TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False

For Each ws In myWb.Worksheets
v = ws.Cells(1).CurrentRegion.Value
ReDim w(1 To dic.Count, 1 To UBound(v, 2) - 4)
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & Format(v(j, 3), "d-mmm-yy") & vbTab & v(j, 4)
n = dic(s)
For k = 5 To UBound(v, 2)
w(n, k - 4) = v(j, k)
Next
Next
Set rngDst = rngDst.End(xlToRight).Offset(, 1)
rngDst.Resize(UBound(w, 1), UBound(w, 2)).Value = w
Next

rngDst.CurrentRegion.Sort rngDst.Cells(3), Header:=xlYes

End Sub

[Yadavagiri]

Hi Mana,

Firstly, I am very sorry for the delayed response and confirmation on this code.

I have implemented this code in my data and I am very happy to confirm that the code is successfully working. You are brilliant and Super Star. :)

One more step required - I see that the consolidated data is created in a new excel. Is there anyway you can amend the above code where the consolidated data is done in the same excel by creating a new sheet named "Consolidated" rather than creating a new excel. This is one update i would require in the above code.

Regards,
Yadavagiri

[mana]

Sub test4()
Dim dic As Object
Const myShtName As String = "Consolidated"
Dim rngDst As Range
Dim ws As Worksheet
Dim v, w()
Dim j As Long, k As Long
Dim s As String
Dim n As Long

Set dic = CreateObject("scripting.dictionary")

On Error Resume Next
Set rngDst = Worksheets(myShtName).Cells(1)
On Error GoTo 0

If rngDst Is Nothing Then
Set rngDst = Worksheets.Add(Worksheets(1)).Cells(1)
rngDst.Worksheet.Name = myShtName
Else
rngDst.CurrentRegion.ClearContents
End If

For Each ws In Worksheets
If ws.Name <> myShtName Then
v = ws.Cells(1).CurrentRegion.Resize(, 4).Value
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & Format(v(j, 3), "d-mmm-yy") & vbTab & v(j, 4)
If Not dic.exists(s) Then dic(s) = dic.Count + 1
Next
End If
Next

rngDst.Resize(dic.Count).Value = Application.Transpose(dic.keys)
rngDst.CurrentRegion.TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False

For Each ws In Worksheets
If ws.Name <> myShtName Then
v = ws.Cells(1).CurrentRegion.Value
ReDim w(1 To dic.Count, 1 To UBound(v, 2) - 4)
For j = 1 To UBound(v, 1)
s = v(j, 1) & vbTab & v(j, 2) & vbTab & Format(v(j, 3), "d-mmm-yy") & vbTab & v(j, 4)
n = dic(s)
For k = 5 To UBound(v, 2)
w(n, k - 4) = v(j, k)
Next
Next
Set rngDst = rngDst.End(xlToRight).Offset(, 1)
rngDst.Resize(UBound(w, 1), UBound(w, 2)).Value = w
End If
Next

rngDst.CurrentRegion.Sort rngDst.Cells(3), Header:=xlYes

End Sub

[Yadavagiri]

Hi Mana,

WoW, This is fantastic and amazing!! This is much more than I required and has met my requirement.!!! I owe you a treat!! :)

Many thanks for your help and getting this done for me and for your prompt responses!!!

Cheers!! You are really a Super Star!!

This request can now be closed !!!

Thanks once again so much!!

Regards,
Yadavagiri