help requested on VBA for combining data over multiple sheets

[Kellens]

Hello,

I have a large number of sheets in my workbook that i would like to combine into one sheet. Every sheet has a similar setup and has 2 rows:

• the first has the coloumn headers in it
• the second has a number of values

the first column contains a unique article number

What i would like to do is have a script that adds all these rows below each other on one sheet.
The values should however be filled in under the corresponding header...
You can find an example excell with the tabs i would like to combine here:

http://www.sonic-websites.be/blog/wp...t-bosch21.xlsx

In the tab result you can see what i'm trying to accomplish (mockup).
I really hope someone could help me with this!!!

For those that don't like to download stuff below a small sample...

Sheet 1

ID	attribute 1	attribute 2	attribute 3	attribute 4
654362168	value	654	value 545	5

<tbody>
</tbody>

Sheet 2

ID	attribute X	attribute 4	attribute 1	attribute Y
1255	value X	123	value 2	Value Y

<tbody>
</tbody>

Combination - result

ID	attribute 1	attribute 2	attribute 3	attribute 4	attribute X	attribute Y
654362168	value	654	value 545	5
1255	value 2			123	value X	value Y

<tbody>
</tbody>

Thanks,

 

[Jake Blackmore]

ok so here goes - the most important thing is that you copy and paste the headers you require into the results tab row 1. Put them in any order you like.

The following code runs through each sheet and attempts to MATCH the header in RESULTS with the header in the sheet for every column in the used range of your Results tab - if it finds it then it returns the Value via an INDEX formula using this code

Option Explicit

Public Sub Combine()
    Dim wks         As Excel.Worksheet
    Dim lngLastRow  As Long
    Dim lngCol      As Long
    Dim strHeader   As String

    For Each wks In ThisWorkbook.Worksheets
        If Not wks.Name = "RESULT" Then
            With ActiveSheet
                lngLastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row + 1
                For lngCol = 1 To ActiveSheet.UsedRange.Columns.Count
                    strHeader = .Cells(1, lngCol).Address
                    With .Cells(lngLastRow, lngCol)
                        .Formula = "=IFERROR(INDEX('" & wks.Name & "'!2:2,1,MATCH(RESULT!" & strHeader & ",'" & wks.Name & "'!1:1,0)),"""")"
                        .Value = .Value
                    End With
                Next lngCol
            End With
        End If
    Next
End Sub

 

[Kellens]

Hello,

I've tried the code above and it runs but gives no outcome.
Most likely since my tab "RESULT" there aren't any headers since they were not created in the previoàus script.

To be clear what i'm looking for is a script that runs trough all tabs (there will be a lot of them, approx 1.000 tabs) and combines all the data in a new Tab.
In this new tab the headers should be added from each tab and the corresponding values (to the headers) should be placed in the rows.

Hope that helped...

 

[Jake Blackmore]

Ok so to get a set of unique headers I created a slightly different bit of code

Option Explicit

Public Sub Combine()
    Dim wks         As Excel.Worksheet
    Dim rngHeader   As Excel.Range
    Dim lngLastRow  As Long
    Dim lngCol      As Long
    Dim strHeader   As String

    Call Worksheets("RESULT").UsedRange.ClearContents
    
    For Each wks In ThisWorkbook.Worksheets 'To generate the Headers
        If Not wks.Name = "RESULT" Then
            For lngCol = 1 To wks.UsedRange.Columns.Count
                strHeader = wks.Cells(1, lngCol).Value
                With Worksheets("RESULT")
                    Set rngHeader = .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
                    If Application.WorksheetFunction.CountIf(rngHeader, strHeader) = 0 Then
                        If rngHeader.Cells(1, 1) = "" Then
                            .Cells(1, rngHeader.Columns.Count).Value = strHeader
                        Else
                            .Cells(1, rngHeader.Columns.Count + 1).Value = strHeader
                        End If
                    End If
                End With
            Next lngCol
        End If
    Next wks

    For Each wks In ThisWorkbook.Worksheets 'To generate the data
        If Not wks.Name = "RESULT" Then
            With Worksheets("RESULT")
                lngLastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row + 1
                For lngCol = 1 To .UsedRange.Columns.Count
                    strHeader = .Cells(1, lngCol).Address
                    With .Cells(lngLastRow, lngCol)
                        .Formula = "=IFERROR(INDEX('" & wks.Name & "'!2:2,1,MATCH(RESULT!" & strHeader & ",'" & wks.Name & "'!1:1,0)),"""")"
                        .Value = .Value
                    End With
                Next lngCol
            End With
        End If
    Next wks
End Sub

Test it and let me know how you get on,
Jake

 

[Kellens]

Hello Jake,

I've tested and i see the code running but i get no result in the "RESULT" tab...
I've uploaded the most current xls to
http://www.sonic-websites.be/blog/wp-content/uploads/2015/02/test-bosch-newest.xlsm

Thanks for all this effort... Hope it works soon

 

[Jake Blackmore]

Can you try swapping

   Call Worksheets("RESULT").UsedRange.ClearContents

for

    Call Worksheets("RESULT").UsedRange.Rows.Delete

 

[Kellens]

WOW !!!!!
As i can see at first glance it seems to work perfectly.

I'll be testing and checking the results and trying the larger files later today (this afternoon).
But so far it looks like it works like a charm

Thanks a million

 

[Jake Blackmore]

Excellent news - knew we would get there in the end.