VBA Find Column Based on 2 Headers

[Alex0013]

Hi All,

I can't figure out how to word this to search properly, so I haven't found something even though I'm sure someone's posted this before...

I'm in the process of converting a list to a grid, based on the values in the grid. I've done this before matching 1 criteria, but having trouble matching to two criteria. Here's what I mean:

List:

Fruit	Apple	50
Fruit	Pear	20
Veggie	Carrot	10
Veggie	Kale	25

<tbody>
</tbody>

Converting to Grid:

Fruit	Fruit	Fruit	Veggie	Veggie	Carb
Pear	Apple	Orange	Carrot	Kale	Pasta
20	50		10	25

<tbody>
</tbody>

Very simple example, but essentially, I need the macro to loop over my list, and place the value in column 3 into by grid, based on looking up the 2-row headers.

If you can just help me identify the column number, I can do the rest. I have 99% of my macro built (much more complex than this), but just trying to figure out how to match a column based on 2 criteria.

Thoughts?

Thanks!
Alex

(Excel 2016)

 

[Brombrough]

Hi Alex0013

Code below will build your grid from scratch every time you rin it.

Hope it helps & enjoy.

Don't forget to Thank /Like if it helps you.

Sub createGrid()    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    Dim lngMax1Row As Long
    Dim i As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")


    lngMax1Row = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row




    For i = 1 To lngMax1Row
        ws2.Cells(1, i) = ws1.Range("A" & i).Value
        ws2.Cells(2, i) = ws1.Range("B" & i).Value
        ws2.Cells(3, i) = ws1.Range("C" & i).Value
    Next i
    Set ws1 = Nothing
    Set ws2 = Nothing


End Sub

 

[Brombrough]

Hi Alex0013

Sorry misread the question.

Code below will update your grid as requested.

Hope it helps & enjoy.

Don't forget to Thank /Like if it helps you.

[/COLOR]Sub updateGrid()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lngType As Long
    Dim oRange As Range
    
    Dim lngMax1Row As Long
    Dim lngMax2Col As Long
    Dim i As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")


    lngMax1Row = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
    lngMax2Col = ws2.Cells(2, ws2.Columns.Count).End(xlToLeft).Column
    Set oRange = ws2.Range(ws2.Cells(2, 1), ws2.Cells(2, lngMax2Col))
    
    For i = 1 To lngMax1Row
        On Error GoTo TypeNotFound
            lngType = Application.WorksheetFunction.Match(ws1.Range("B" & i).Value, oRange, 0)
                        
            ws2.Cells(3, lngType) = ws1.Range("C" & i).Value
    Next i
    
    Set oRange = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Exit Sub
TypeNotFound:
    
    MsgBox "Type not Found Please add.  - " & ws1.Range("B" & i).Value
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set oRange = Nothing
End Sub
[COLOR=#333333]

 

[Alex0013]

Hello,

Does that actually match both criteria though? Isn't it evaluating only 1 column to 1 row? From reading your code, it looks like it is only evaluating that Apple = Apple for instance, but not that Fruit-Apple matches Fruit-Apple.

Maybe my example was too generic, but I need it to evaluate the criteria in BOTH columns (aka, Veggie-Apple, or Fruit-Carrot are also both possible combinations, so it must evaluate BOTH criteria).

Thanks,
Alex

 

[Alex0013]

So I figured out something that would work, I don't 100% love it though because it doesn't do any error handling. If it doesn't find a result, I still end up with "46" as my index, whereas I would prefer it to give me an error message. Also, I'd like it to be dynamic, so I don't have to hard-code 46, but I tried to a "wsResult.Range(Range("C1"), Range("C1").End(xlRight)).Count" but it didn't work. But either way, this will do me unless someone has a better way.

Thanks for trying to help!

            Dim index As Integer
            For index = 0 To 46 'Insert a number higher than the number of columns you have in your Grid
                If wsResult.Range("C1").Offset(, index).Value = queryCell.Offset(, 3).Value And wsResult.Range("C2").Offset(, index).Value = queryCell.Offset(, 2).Value Then
                  Exit For
                End If
            Next index

 

[Fluff]

Another option

Sub Alex0013()
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
      Dic(Cl.Value)(Cl.Offset(, 1).Value) = Cl.Offset(, 2).Value
   Next Cl
   For Each Cl In Range("K3", Cells(1, Columns.Count).End(xlToLeft).Offset(2))
      If Dic.Exists(Cl.Offset(-2).Value) Then
         Cl.Value = Dic(Cl.Offset(-2).Value)(Cl.Offset(-1).Value)
      End If
   Next Cl
End Sub

With your list in A2 downwards & the grid starting in K1

 

[Brombrough]

Hi Alex0013,

I was just trying to make things simple.

I've now added a helper row, which gets deleted at end of procedure, as well as it item is not found it auto adds a column to Grid and fills in value

Hope this helps

Sub updateGrid1()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lngType As Long
    Dim oRange As Range
    Dim strCheck As String
    Dim lngMax1Row As Long
    Dim lngMax2Col As Long
    Dim i As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")




    lngMax1Row = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
    lngMax2Col = ws2.Cells(2, ws2.Columns.Count).End(xlToLeft).Column
    
    ws2.Rows(3).Delete
    ws2.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    For i = 1 To lngMax2Col
        ws2.Cells(1, i).Value = ws2.Cells(2, i) & "_" & ws2.Cells(3, i)
    Next i


    
    Set oRange = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lngMax2Col))
    
    For i = 1 To lngMax1Row
        On Error GoTo TypeNotFound
            strCheck = ws1.Range("A" & i).Value & "_" & ws1.Range("B" & i).Value
            lngType = Application.WorksheetFunction.Match(strCheck, oRange, 0)
            ws2.Cells(4, lngType) = ws1.Range("C" & i).Value
    Next i
    
    
    ws2.Rows("1:1").Delete Shift:=xlUp
    
    Set oRange = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Exit Sub
TypeNotFound:
    'add new column to sheet2


    ws2.Cells(1, lngMax2Col + 1) = ws1.Range("A" & i).Value & "_" & ws1.Range("B" & i).Value
    ws2.Cells(2, lngMax2Col + 1) = ws1.Range("A" & i).Value
    ws2.Cells(3, lngMax2Col + 1) = ws1.Range("B" & i).Value
    
    lngMax2Col = ws2.Cells(2, ws2.Columns.Count).End(xlToLeft).Column
    Set oRange = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lngMax2Col))
    Resume
End Sub