Vlookup Col_Index_Number by Header based on Array iteration?

Question

I am running into an issue with my current code - I am hoping someone can assist:

Issue: I am trying to do a Vlookup from Workbook "ABC". The issue is, I am trying to change the VLOOKUP Col_Index_Number based on a header on workbook ABC...

So for example: For MyArray "Food" I am looking to Vlookup Column_Index_Num for "Food-Mexican" Column on workbook ABC, For MyArray Appetizers, I am looking to Vlookup Column_Index-Num for "Appetizers-American"...

Additionally, the columns will not always be in the same place for each report so it has to be based on the row 1 header of ABC workbook.

Also, sometimes the Array iteration might be skipped, if say for example, "Non-AlcoholicDrinks" is not found.

---

Sub WIP()
    Dim wb As Workbook
    Dim wsMain As Worksheet
    Dim wsLookup As Worksheet
    Dim rng As Range
    Dim rng2 As Range
    Dim rFind1 As Range
    Dim rFind2 As Range
    Dim rFind3 As Range
    Dim MyArray As Variant
    Dim LookupHeaders As Variant
    Dim LookupHeaders2 As Variant
    Dim LR As Long
    Dim i As Long
    Dim PriceCol As Long
    Dim pricecol2 As Long
    Dim LastColumn As Long
     Dim LastColumn2 As Long
       Dim LastColumn3 As Long
     Dim LastColumn4 As Long
    Dim IndexCol As Long

     'Unformatted Price Row
  Sheets("Consolidate List").Select
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("J:N").Delete
    Columns("J:J").Select
    ActiveWindow.FreezePanes = True
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "New Price"
    ActiveCell.Interior.ColorIndex = 22
         Range("H3:H" & LR).Formula = "=VLOOKUP(RC[-7],'Connect Report'!C[-7]:C[-6],2,FALSE)"
         ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
 Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("I2").Select
    ActiveCell.FormulaR1C1 = "Difference"
    ActiveCell.Interior.ColorIndex = 22
    Range("I3:I" & LR).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
         ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
 Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Set wb = ActiveWorkbook
     Sheets("Consolidate List").Select
    Set wsMain = wb.ActiveSheet
    Set wsLookup = wb.Sheets("Connect Report")     '<-- Change to correct sheet name for the Lookup sheet
    LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    MyArray = Array("US", "SPAIN", "California")
    LookupHeaders = Array("TTIER", "Time333", "Round6")
  LookupHeaders2 = Array("TELLER5", "Fly7", "Mine4")

    For i = LBound(MyArray) To UBound(MyArray)
        With wsMain.Rows(1)
            Set rFind1 = .Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not rFind1 Is Nothing Then
                Set rng = rFind1.Offset(1).Resize(, 8)
                PriceCol = Application.Match("New Opposed Price", rng, 0)
                LastColumn = rFind1.Column + PriceCol
                If wsMain.Cells(rng.Row, LastColumn) <> "New Opposed Price" Then
                    wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng.Row, LastColumn).Value = "New Opposed Price"
                    wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
                    LastColumn2 = LastColumn + 1
                     wsMain.Columns(LastColumn2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng.Row, LastColumn2).Value = "Difference"
                    wsMain.Cells(rng.Row, LastColumn2).Interior.ColorIndex = 22

                Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlWhole)
                If Not rFind2 Is Nothing Then
                    IndexCol = rFind2.Column
                    wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"

                      wsMain.Cells(rng.Row + 1, LastColumn2).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
                              Else
                    MsgBox "Excel could not find " & LookupHeaders(i) & " in the lookup table."
                End If

                Set rng2 = rFind1.Offset(1).Resize(, 8)
                pricecol2 = Application.Match("New Muted Price", rng, 0)
                LastColumn3 = rFind1.Column + pricecol2
                   If wsMain.Cells(rng.Row, LastColumn3) <> "New Muted Price" Then
                    wsMain.Columns(LastColumn3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng2.Row, LastColumn3).Value = "New Muted Price"
                    wsMain.Cells(rng2.Row, LastColumn3).Interior.ColorIndex = 22
                    LastColumn4 = LastColumn3 + 1
                      wsMain.Columns(LastColumn4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng2.Row, LastColumn4).Value = "Difference"
                    wsMain.Cells(rng2.Row, LastColumn4).Interior.ColorIndex = 22
                End If

                      Set rFind3 = wsLookup.Rows(1).Find(LookupHeaders2(i), wsLookup.Range("A1"), xlValues, xlWhole)
                If Not rFind3 Is Nothing Then
                    IndexCol = rFind3.Column
                    wsMain.Cells(rng2.Row + 1, LastColumn3).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng2.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"

                      wsMain.Cells(rng2.Row + 1, LastColumn4).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"

                    Else
                    MsgBox "Excel could not find " & LookupHeaders2(i) & " in the lookup table."
                End If
                End If
             End If
        End With
    Next i
End Sub

Can anyone help with this? I am completely lost on how to resolve this issue. Also, I am hoping that I described the issue clearly... it is quite confusing.

Answer 1

This is a User Defined Function I've wrote to find the range of based on column header, it uses .find method to find the target cells. Works well if you column titles are are the top of your worksheet.

I hope this solves your problem, you could just findout the target column, by using .column on the range returned.

'define a range by looking for a specific text title, and return all the cells to the lastrow of the sheet as a range
Private Function defineColRange(ByVal targetWorkSheet As Worksheet, ByVal targetValue As String, _
                                Optional ByVal visibleOnly As Boolean, Optional ByVal rtnNoTitle As Boolean, _
                                Optional ByVal searchByColumn, Optional ByVal searchBackwards) As Range
    Dim targetlastRow As Long
    Dim targetlastCol As Long
    Dim returnRange As Range
    Dim findTarget As Range

'default visible only mode off

    If IsMissing(visibleOnly) Then
         visibleOnly = False
    End If
    If IsMissing(rtnNoTitle) Then 'Don't return title cell in the range returned
        rtnNoTitle = False
    End If
    If IsMissing(searchByColumn) Then 'Search vertically by column, instead of by rows
        searchByColumn = False
    End If
    If IsMissing(searchBackwards) Then 'Search backwards by rows
        searchBackwards = False
    End If

    'test if targetWorkSheet is not empty
    If targetWorkSheet Is Nothing Then
        MsgBox ("Worksheet pass failed!"), vbExclamation
        Exit Function
    End If

    targetWorkSheet.Activate
    targetlastRow = targetWorkSheet.UsedRange.Find(What:="*", _
                    after:=Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    Searchorder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

    targetlastCol = targetWorkSheet.UsedRange.Find(What:="*", _
                    after:=Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    Searchorder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column

    'find the range

    If searchByColumn = True Then
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByColumns, _
                        SearchDirection:=xlNext, MatchCase:=False)
    ElseIf searchBackwards = True Then
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, targetlastCol), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
                        SearchDirection:=xlPrevious, MatchCase:=False)
    Else
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
    End If

    If findTarget Is Nothing Then
        Debug.Print ("Did not find columne title """ & targetValue & ""), vbExclamation
        Exit Function
    Else
        Dim tRow, tCol As Long
        tRow = findTarget.Row
        tCol = findTarget.Column

        On Error Resume Next
        If visibleOnly = False Then
            If rtnNoTitle = False Then
                Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol))
                Set defineColRange = returnRange
            Else
                Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol))
                Set defineColRange = returnRange
            End If
        Else
            If rtnNoTitle = False Then
                Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
                Set defineColRange = returnRange
            Else
                Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
                Set defineColRange = returnRange
            End If
        End If

        If Err <> 0 Then
            Debug.Print "Worksheet: " & targetWorkSheet.Name & " Column Name: " & targetValue
        End If
        On Error GoTo 0
        Err.Clear
    End If

End Function

Answer 2

I believe something like this should work for you. Give it a try and let me know.

Sub tgr()

    Dim wb As Workbook
    Dim wsMain As Worksheet
    Dim wsLookup As Worksheet
    Dim rng As Range
    Dim rFind1 As Range
    Dim rFind2 As Range
    Dim MyArray As Variant
    Dim LookupHeaders As Variant
    Dim LR As Long
    Dim i As Long
    Dim PriceCol As Long
    Dim LastColumn As Long

    Set wb = ActiveWorkbook
    Set wsMain = wb.ActiveSheet
    Set wsLookup = wb.Sheets("ABC")     '<-- Change to correct sheet name for the Lookup sheet
    LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    MyArray = Array("TEST", "Food", "Non-AlcoholicDrinks", "Appetizers", "Alcoholic Drinks")
    LookupHeaders = Array("TestHeader", "FoodHeader", "Non-AlcoholicDrinksHeader", "AppetizersHeader", "Alcoholic DrinksHeader")

    For i = LBound(MyArray) To UBound(MyArray)
        Set rFind1 = wsMain.Rows(1).Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind1 Is Nothing Then
            Set rng = rFind1.Offset(1).Resize(, 8)
            PriceCol = Application.Match("Price", rng, 0)
            LastColumn = rFind1.Column + PriceCol
            If wsMain.Cells(rng.Row, LastColumn) <> "Difference" Then
                wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                wsMain.Cells(rng.Row, LastColumn).Value = "Difference"
                wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
            End If
            Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlPart)
            If Not rFind2 Is Nothing Then
                With wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2)
                    .Formula = "=VLOOKUP(A" & rng.Row + 1 & "," & wsLookup.Range("A:AL").Address(External:=True) & "," & rFind2.Column & ",FALSE)"
                    .Value = .Value 'Convert to values
                End With
            End If
        End If
    Next i

End Sub