VBA to match headers and copy data from below

[billionaire2003]

Hi everyone,

I am looking for some VBA code to help me with the following problem, it would be great if anyone could help.

I have two excel sheets, both with identical headers except they are in a different order. Sheet1 has data, Sheet2 is blank except for the headers.

In sheet2 I would like to find the column in sheet1 that has the corresponding header, and copy all the data in the column and paste into correct column on sheet2. I would like to do this for all columns in sheet2. For example, the column with header name 'Fruit Type' in sheet2. I would like to find the column in sheet1 with the header 'Fruit Type', and copy all the data in that column into the 'Fruit Type' column in sheet2.


Any help welcomed.

Thanks

 

[alexdi]

Absolutely. Here's a link to a file set with more detail:

Import_example1.zip

drive.google.com

 

[mumps]

Make sure that both workbooks are open. Delete all your comments starting in row 9 of the DestSheet in the sample file you posted if they exist. Place this macro in a regular module in the destination workbook and run it from there.

Sub MatchHeaders()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, WB As Workbook, srcWB As Workbook, ID As Range, person As Range, group As Range, sCol As Long, tName As String
    Dim lCol As Long, rng As Range, oTbl As ListObject
    Set desWS = ThisWorkbook.Sheets("DestSheet")
    With desWS
        lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        tName = .ListObjects(1).Name
    End With
    sCol = Sheets("Parameters").Range("B:B").Find(tName, LookIn:=xlValues, lookat:=xlWhole).Offset(, 2).Value + 1
    For Each WB In Workbooks
        If WB.Name <> ThisWorkbook.Name Then
            Set srcWB = WB
        End If
    Next WB
    For Each oTbl In srcWB.Sheets(1).ListObjects
        If oTbl.Name = tName Then
            For Each ID In desWS.Range("B3", desWS.Range("B" & Rows.Count).End(xlUp))
                Set person = srcWB.Sheets(1).Range("B:B").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
                If Not person Is Nothing Then
                    For Each rng In Range(Cells(2, sCol), Cells(2, lCol))
                        Set group = srcWB.Sheets(1).Rows(2).Find(rng, LookIn:=xlValues, lookat:=xlWhole)
                        If Not group Is Nothing Then
                            Cells(ID.Row, rng.Column) = srcWB.Sheets(1).Cells(person.Row, group.Column)
                        End If
                    Next rng
                End If
            Next ID
        End If
    Next oTbl
    Application.ScreenUpdating = True
End Sub

 

[alexdi]

That works really well for the sample, thank you. There are some hardcoded elements that make it tricky to adapt, though.

* The relevant worksheet in the Source workbook may not be the first one.
* A worksheet in either workbook may have more than one table. I don't know if any particular table will be first ListObject, or that the last column with data necessarily corresponds to the first table.
* The tables can be located anywhere. The table's data might not start in column B or row 3.
* The column name for the PK column is in the Parameters table. That PK column may not be the first column of the Source table.

If it possible to write this such that it uses ranges in the tables themselves rather than the worksheet?

 

[mumps]

As you are most likely aware, macros depend on patterns and rules. If the rules can be defined, then the macro will be able to follow them to solve the problem. Your situation has many random variables which makes the creation of the rules very difficult. I'm not trying to suggest that a solution is impossible because it may be. Could you post copies of your files (preferably un-zipped) that are more representative of the points you mentioned in your last post, that is, a Source workbook where the relevant sheet is not the first one, workbooks containing more than one table, etc.? Also, include any information which could be of additional help. I can't promise a solution but it will be interesting to try. If I can't find a solution, it may take a Forum member with more advanced VBA skills than I have.

 

[alexdi]

Definitely. Another sample is below, though it's important to note that this is just one permutation. There could be any number of sheets before the relevant Source sheet, and any number of unrelated columns in various places in the Source table.

Excel - Google Drive

drive.google.com

I believe it's possible to reference the tables directly if they exist (so the absolute cell positions in the worksheet are not required) and to do a lookup for each relevant column names within the table (so the unrelated columns and column order don't matter, and you can find the end of that specific table without worrying about others), but getting the syntax right for the range lookups and traversal is eluding me.

 

[mumps]

Try:

Sub MatchHeaders()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, WB As Workbook, srcWB As Workbook, ID As Range, person As Range, group As Range, sCol As Long, tName As String
    Dim lCol As Long, rng As Range, oTbl As ListObject, PKC As String, ws As Worksheet, fRow As Long
    Set desWS = ThisWorkbook.Sheets("DestSheet")
    tName = Sheets("Parameters").ListObjects("Params").ListColumns("TableName").DataBodyRange(1).Value
    PKC = Sheets("Parameters").ListObjects("Params").ListColumns("PKColumnName").DataBodyRange(1).Value
    lCol = desWS.ListObjects("UserGroup").Range.Columns.Count
    sCol = Sheets("Parameters").ListObjects("Params").Range.Cells(2, 3)
    For Each WB In Workbooks
        If WB.Name <> ThisWorkbook.Name Then
            Set srcWB = WB
        End If
    Next WB
    For Each ws In srcWB.Sheets
        For Each oTbl In ws.ListObjects
            If oTbl.Name = tName Then
                For Each ID In desWS.ListObjects(tName).ListColumns(PKC).DataBodyRange.Cells
                    Set person = ws.ListObjects(tName).ListColumns(PKC).Range.Find(ID, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not person Is Nothing Then
                        fRow = ws.ListObjects(tName).Range.Cells(1, 1).Row
                        For Each rng In desWS.ListObjects(tName).Range(1, sCol).Resize(, lCol - sCol + 1)
                            Set group = ws.Rows(fRow).Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not group Is Nothing Then
                                desWS.Cells(ID.Row, rng.Column) = ws.Cells(person.Row, group.Column)
                            End If
                        Next rng
                    End If
                Next ID
            End If
        Next oTbl
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[alexdi]

That's really cool! It seems to have no trouble with anything I mentioned earlier. I'll try adapting it soon to larger datasets. Thanks again!

 

[mumps]

My pleasure.

 

[alexdi]

I've discovered that this code works very well up to certain table size, but may need a different approach for large one.

The full workbook has about twenty tables, each with a maximum size of 10,000 rows x 50 columns. Running the code against each one takes over thirty minutes on a fast machine. The limiting factor is that a worksheet write occurs for every cell value, and this operation is very slow:

> destWS.Cells(ID.Row, rng.Column) = ws.Cells(rData.Row, cName.Column)

With the same sample sheets, is there a way to write to an array instead, and then do one write of the completed array to the table? Or perhaps even to pull both the source and destination tables into arrays, perform the same operations, and write the result?

 

[alexdi]

I managed to adapt your example into this:

Dim srcArr() As Variant
Dim destArr() As Variant

Dim srcColLength As Long
Dim srcRowLength As Long
Dim destColLength As Long
Dim destRowLength As Long

Dim c As Long
Dim dc As Long
Dim sc As Long
Dim dr As Long
Dim sr As Long

Dim srcKeyCol As Long
Dim destKeyCol As Long

Dim destCol As Long
Dim destKey As String

srcArr = srcTbl.Range
destArr = destTbl.Range

srcColLength = UBound(srcArr, 2) - LBound(srcArr, 2) + 1
srcRowLength = UBound(srcArr, 1) - LBound(srcArr, 1) + 1
destColLength = UBound(destArr, 2) - LBound(destArr, 2) + 1
destRowLength = UBound(destArr, 1) - LBound(destArr, 1) + 1

' Find src column for ID
For c = 1 To srcColLength
    If srcArr(1, c) = keyCol Then
        srcKeyCol = c
    End If
Next c

' Find dest column for ID
For c = 1 To destColLength
    If destArr(1, c) = keyCol Then
        destKeyCol = c
    End If
Next c
    
For dc = sCol To lCol
    destKey = destArr(1, dc)   
    For dr = 2 To destRowLength
        For sc = 1 To srcColLength
            If srcArr(1, sc) = destKey Then
                For sr = 2 To srcRowLength
                    If srcArr(sr, srcKeyCol) = destArr(dr, destKeyCol) Then
                        destArr(dr, dc) = srcArr(sr, sc)
                    End If
                Next sr
            End If
        Next sc
    Next dr
Next dc
                    
Dim slice As Variant
                    
For dc = sCol To lCol
    slice = Application.Index(destArr, 0, dc)
    destTbl.ListColumns(dc).Range.value = slice
Next dc

Not very elegant, but quite fast. Thanks again!