Merge Two Tables and Convert to Data List

[Gimics]

Hello,

I have two tables that are maintained separately, but share common elements. Based on those common elements, I would like to merge the tables and extend them into a full data list.

The first table has headings across the top (let's call them location groups) that need to be looked up in the second table, which will contain multiple records (let's called them locations) of those headings associated with additional fields. After looking the value up, I want to create a third table that's a list of all of the source data and looked up values. Much easier to explain with visuals:

Table 1(source data):

	A	B	C	D
1	Fruit Types	Stores	Ecommerce	Corporate
2	Apple	Gala	Gala	Fuji
3	Orange	Tangerine	Mandarin	Madarin

<tbody>
</tbody>

Table 2(mapping table):

	A	B
1	Location Groups	Locations
2	Stores	Store 100
3	Stores	Store 200
4	Stores	Store 300
5	Ecommerce	Canada Website
6	Ecommerce	USA Website
7	Ecommerce	Global Website
8	Corporate	Head Office

<tbody>
</tbody>

Table 3(output; for each fruit type and fruit variety, lookup location group and create a record for each location):

	A	B	C	D
1	Fruit Types	Fruit Variety	Location Group	Location
2	Apple	Gala	Stores	Store 100
3	Apple	Gala	Stores	Store 200
4	Apple	Gala	Stores	Store 300
5	Apple	Gala	Ecommerce	Canada Website
6	Apple	Gala	Ecommerce	USA Website
7	Apple	Gala	Ecommerce	Global Website
8	Apple	Fuji	Corporate	Head Office
9	Orange	Tangerine	Stores	Store 100
10	Orange	Tangerine	Stores	Store 200
11	Orange	Tangerine	Stores	Store 300
12	Orange	Mandarin	Ecommerce	Canada Website
13	Orange	Mandarin	Ecommerce	USA Website
14	Orange	Mandarin	Ecommerce	Global Website
15	Orange	Mandarin	Corporate	Head Office

<tbody>
</tbody>

I have many more columns and rows of data, but this basic layout would solve my problem. I know how to look through the source table and then how to update the output table with those values, but I don't know how to find multiple values in the mapping table and return multiple values.

Say I've declared variables for the source table (Table1) and mapping table (Table2), including their rows, columns and data, and selected an output range for Table3 as a single cell (outRng); this would roughly be where I'm at (the code below isn't complete for all of the headings, but I can figure that part out...this is just for the mapping lookup):

For i = 1 to Table1.rows.count
    For j = 1 To Table1.columns.count
        If Not Table1.body(i, j) = "" Then
            Set foundRng = Table2Groups.Find(Table1Heading(,j), LookIn:=xlValues)
            outRng.Offset(k - 1).Resize(foundRng.Rows.Count).Value = foundRng.Offset(, 1).Value
            k = k + foundRng.Rows.Count
        Else
        End If
    Next j
Next i

This, obviously, only returns one value, as range.find only returns the range of the first found cell. This would be my resulting table:

	A	B	C	D
1	Fruit Types	Fruit Variety	Location Group	Location
2	Apple	Gala	Stores	Store 100
3	Apple	Gala	Ecommerce	Canada Website
4	Apple	Fuji	Corporate	Head Office
5	Orange	Tangerine	Stores	Store 100
6	Orange	Mandarin	Ecommerce	Canada Website
7	Orange	Mandarin	Corporate	Head Office

<tbody>
</tbody>

What am I missing? It would be great if I could use a range.resize(foundrange.size) = foundrange.offset(1) kind of formula here, but maybe I can only do this with multiple loops?

Thanks in advance!

 

[DanteAmor]

So if you have 3 tables, try this macro

Change data in red by your information

A small change:

Sub Convert_Data_List()
    Dim lo1 As ListObject, lo2 As ListObject, lo3 As ListObject
    Dim elem As Range, b As Range, sh As Worksheet
    Dim j As Long, cell As String, n As Long
    
    Application.ScreenUpdating = False
    Set sh = Sheets("[COLOR=#ff0000]Data[/COLOR]")
    Set lo1 = sh.ListObjects("[COLOR=#ff0000]Source[/COLOR]")
    Set lo2 = sh.ListObjects("[COLOR=#ff0000]mapping[/COLOR]")
    Set lo3 = sh.ListObjects("[COLOR=#ff0000]output[/COLOR]")
    
    With lo3.DataBodyRange
        If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        .Rows(1).ClearContents
    End With
    
    For Each elem In lo1.ListColumns(1).DataBodyRange
        For j = 2 To lo1.ListColumns.Count
            Set b = lo2.Range.Find(lo1.HeaderRowRange(, j), LookAt:=xlWhole)
            If Not b Is Nothing Then
                cell = b.Address
                Do
                    n = lo3.DataBodyRange.Rows.Count
                    [COLOR=#ff0000]lo3.DataBodyRange(n, 1).Resize(1, 4).Value = Array(elem, elem.Offset(, j - 1), b, b.Offset(, 1))[/COLOR]
                    
                    lo3.ListRows.Add AlwaysInsert:=True
                    Set b = lo2.Range.FindNext(b)
                Loop While Not b Is Nothing And b.Address <> cell
            End If
        Next
    Next
End Sub

 

[DanteAmor]

Well, I put the code for 3 sheets, assumes that your information starts in cell A1 for the 3 sheets.

Sub Convert_Data_List2()
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, elem As Range, head As Range, n As Long
    
    Set sh1 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
    Set sh2 = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
    Set sh3 = Sheets("[COLOR=#ff0000]Sheet3[/COLOR]")
    sh3.Rows("2:" & Rows.Count).ClearContents
    
    For Each elem In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
        For Each head In sh1.Range("B1", sh1.Cells(1, Columns.Count).End(xlToLeft))
            sh2.Range("A1").AutoFilter 1, head
            n = Application.CountA(sh2.AutoFilter.Range.Columns(1).Offset(1).SpecialCells(xlCellTypeVisible))
            sh2.AutoFilter.Range.Offset(1).Copy sh3.Range("C" & Rows.Count).End(xlUp)(2)
            sh3.Range("A" & Rows.Count).End(xlUp)(2).Resize(n, 2).Value = Array(elem, sh1.Cells(elem.row, head.Column))
        Next
    Next
End Sub

 

[Gimics]

Thanks all for the responses!

As the data will be changing periodically, I was really focused on a VBA answer to assist with automation.

I actually have a combination of tables (real, formatted) and data ranges, so I had to combine a few suggestions.

I went with lrobbo314's approach in creating an arraylist and then transposing the list to a destination - I'd never used this before and your code looked so clean, so I thought I would try it out!

I made a couple of tweaks to facilitate using ranges and tables and the additional header rows I had, but it worked first try exactly as I wanted.

One thing I was a little hung up on was the .texttocolumns resulting in numeric values (I left that part out in my description) being truncated if they're too long, as is always the case with text to columns. I just added a fieldinfo:=array(1,2)... etc for all of the columns to be formatted as text.

At the end of the day, it's still just looping through the mapping table to join all of the values, where it can find joinable values. I was worried about performance, but even with my output range being 35,000 records, the macro runs in seconds.

Thanks again!

 

[DanteAmor]

Thanks all for the responses!

As the data will be changing periodically, I was really focused on a VBA answer to assist with automation.

I actually have a combination of tables (real, formatted) and data ranges, so I had to combine a few suggestions.

I went with lrobbo314's approach in creating an arraylist and then transposing the list to a destination - I'd never used this before and your code looked so clean, so I thought I would try it out!

I made a couple of tweaks to facilitate using ranges and tables and the additional header rows I had, but it worked first try exactly as I wanted.

One thing I was a little hung up on was the .texttocolumns resulting in numeric values (I left that part out in my description) being truncated if they're too long, as is always the case with text to columns. I just added a fieldinfo:=array(1,2)... etc for all of the columns to be formatted as text.

At the end of the day, it's still just looping through the mapping table to join all of the values, where it can find joinable values. I was worried about performance, but even with my output range being 35,000 records, the macro runs in seconds.

Thanks again!

I'm glad you found a solution, just in case there are other codes that maybe can serve as a guide for another situation.
Greetings and thanks for the feedback.

 

[lrobbo314]

I really like Sandy’s solution. I originally tried to do it via power query, but since I’m better with VBA, I leaned on that crutch. It seemed so simple once I saw how sandy did it. Always nice to see the multiple solutions.

Happy to hear that you got a solution that works for you.

 

[Gimics]

Hey all - just an update for an issue I hadn't identified (mostly for future use cases of people who might stumble across this).

When transposing the array into excel cells, Excel thought all of the values were the same numeric value if the strings were all filled with numeric values.

In lroobo's second post, if the Fruit, fType, cHead, and T2.DataBodyRange.cells(k,2) values were all numeric, excel would transpose them as a number, without the comma delimiter we had inserted as part of his "xJoin" function.

To get around this, I added quotes around all of the strings (which is common practice with formatted comma separated value files (.csv)).

I've updated his code to show what this looked like and also included my updates to the text-to-columns method to format the output as text as mentioned in my prior post (see changes in red):

Same thing but adjusted to use tables instead of loading ranges to arrays.

Sub Combo2()
Dim T1 As ListObject: Set T1 = Sheets("Sheet1").ListObjects("Table1")
Dim T2 As ListObject: Set T2 = Sheets("Sheet1").ListObjects("Table2")
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim Fruit As String, fType As String, cHead As String


AL.Add xJoin("[COLOR=#ff0000]""[/COLOR],[COLOR=#ff0000]""[/COLOR]", [COLOR=#ff0000]""[/COLOR]"Fruit Types", "Fruit Variety", "Location Group", "Location"[COLOR=#ff0000]""[/COLOR])


For i = 1 To T1.DataBodyRange.Rows.Count
    Fruit = T1.DataBodyRange.Cells(i, 1)
    For j = 2 To T1.DataBodyRange.Columns.Count
        cHead = T1.HeaderRowRange.Cells(1, j)
        fType = T1.DataBodyRange(i, j)
        For k = 1 To T2.DataBodyRange.Rows.Count
            If T2.DataBodyRange.Cells(k, 1) = cHead Then
                AL.Add xJoin("[COLOR=#ff0000]""[/COLOR],[COLOR=#ff0000]""[/COLOR]", [COLOR=#ff0000]"""" & [/COLOR]Fruit, fType, cHead, T2.DataBodyRange.Cells(k, 2) [COLOR=#ff0000]& """"[/COLOR])
            End If
        Next k
    Next j
Next i


With Range("R1").Resize(AL.Count) 'Change this range for where you want your results to show up
    .Value = Application.Transpose(AL.toArray)
    .TextToColumns DataType:=xlDelimited, Comma:=True, [COLOR=#ff0000]FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2))[/COLOR]
End With


End Sub


Function xJoin(del As String, ParamArray arg() As Variant) As String
xJoin = Join(arg, del)
End Function