VBA Function to Return LOOKUP Values Based on Column Range

Question

I am relatively new to VBA and would need help from the community on the below logic. I have the following table

My Actual Data Table is as follows

My Expected Output is as follows:

I tried using index value to the cat codes and tried but I am stuck for logic here and not able to proceed. Thanks for your help.

Note: The Actual data need not contain the Catcode, for example value belonging to CatCode A will not always contain A in the value. I would to categorize all the values between two catcodes to the cat code that follows it.

Answer 1

Lookup Based on Column Range

Adjust the values in the constants section (e.g. The sheet names can be all the same, the first rows or columns can be different etc.).

New Version

Option Explicit

Sub LookupBasedOnColumnRange()

    Const Head1 As String = "CatCode"   ' 1st Column Header
    Const Head2 As String = "Values"    ' 2nd Column Header
    Const cSheet As String = "Sheet1"   ' CatCode Sheet Name
    Const cFR As Long = 2               ' CatCode First Row Number (no header)
    Const cCol As Variant = 1           ' CatCode Column (e.g. 1 or "A")
    Const aSheet As String = "Sheet2"   ' Actual Sheet Name
    Const aFR As Long = 2               ' Actual First Row Number (no header)
    Const aCol As Variant = 1           ' Actual Column (e.g. 1 or "A")
    Const rSheet As String = "Sheet3"   ' Result Sheet Name
    Const rCel As String = "A1"        ' Result First Cell Range Address

    Dim rng As Range        ' CatCode Non-Empty 1-Column Range,
                            ' Actual Non-Empty 1-Column Range,
                            ' Result 2-Column Range
    Dim CatCode As Variant  ' CatCode Array
    Dim Actual As Variant   ' Actual Array
    Dim Result As Variant   ' Result Array
    Dim i As Long           ' CatCode Array Elements Counter
    Dim j As Long           ' Actual Array Elements Counter,
                            ' Result Array 1st Dimension (Rows) Elements Counter
    ' Change to "As Long" if only numbers
    ' or to "As Variant" if there are numbers and strings.
    Dim CurC As String      ' Current CatCode
    Dim CurA As String      ' Current Actual

    ' Write ranges to arrays.
    With ThisWorkbook.Worksheets(cSheet)
        Set rng = .Columns(cCol).Find(What:="*", LookIn:=xlFormulas, _
          SearchDirection:=xlPrevious)
        CatCode = .Range(.Cells(cFR, cCol), rng)
    End With
    With ThisWorkbook.Worksheets(aSheet)
        Set rng = .Columns(aCol).Find(What:="*", LookIn:=xlFormulas, _
          SearchDirection:=xlPrevious)
        Actual = .Range(.Cells(aFR, aCol), rng)
    End With
    Set rng = Nothing

    ' Resize Result Array (Same first dimension (rows) as Actual Array).
    ReDim Result(1 To UBound(Actual) + 1, 1 To 2) ' '+1' for headers
    ' Write headers to Result Array.
    Result(1, 1) = Head1
    Result(1, 2) = Head2
    ' Calculate and write data to Result Array.
    j = 1
    On Error GoTo ErrorHandler
        For i = 1 To UBound(CatCode)
            CurC = CatCode(i, 1)
            Do
                ' If CatCode is missing, Run-time error '9'.
                CurA = Actual(j, 1)
                Result(j + 1, 1) = CurC
                Result(j + 1, 2) = CurA
                j = j + 1
            Loop Until CurA = CurC Or j = UBound(Result) + 1
            ' "j = UBound(Result) + 1" prevents infinite loop
            ' if CatCode missing.
        Next i
    On Error GoTo 0

    ' Erase arrays not needed anymore.
    Erase CatCode
    Erase Actual

    With ThisWorkbook.Worksheets(rSheet)
        ' Clear contents of columns of Result Range.
        .Range(rCel).Resize(.Rows.Count - Range(rCel).Row + 1, 2).ClearContents
        ' Define Result Range.
        Set rng = .Range(rCel).Resize(UBound(Result), UBound(Result, 2))
    End With

    ' Copy Result Array to Result Range.
    rng = Result

    ' Inform user.
    MsgBox "Transferred Result(" & UBound(Result) & "x" & UBound(Result, 2) _
      & ").", vbInformation, "Custom Message"

    GoTo exitProcedure

ErrorHandler:
    If Err.Number = 9 Then
        MsgBox "CatCode '" & CurC & "' missing.", vbCritical, "Custom Message"
        Err.Clear: GoTo exitProcedure
    End If
    If Err.Number > 0 Then
        MsgBox "An unexpected error occurred. Error '" _
          & Err.Number & "': " & Err.Description, vbCritical, "Custom Message"
        Err.Clear: GoTo exitProcedure
    End If

exitProcedure:

End Sub

Old Version Improved

Option Explicit

Sub LookupBasedOnColumnRangeFirst()

    Const Head1 As String = "CatCode"   ' 1st Column Header
    Const Head2 As String = "Values"    ' 2nd Column Header
    Const cSheet As String = "Sheet1"   ' CatCode Sheet Name
    Const cFR As Long = 2               ' CatCode First Row Number (no header)
    Const cCol As Variant = 1           ' CatCode Column (e.g. 1 or "A")
    Const aSheet As String = "Sheet2"   ' Actual Sheet Name
    Const aFR As Long = 2               ' Actual First Row Number (no header)
    Const aCol As Variant = 1           ' Actual Column (e.g. 1 or "A")
    Const rSheet As String = "Sheet3"   ' Result Sheet Name
    Const rCel As String = "A1"        ' Result First Cell Range Address

    Dim rng As Range        ' CatCode Non-Empty 1-Column Range,
                            ' Actual Non-Empty 1-Column Range,
                            ' Result 2-Column Range
    Dim CatCode As Variant  ' CatCode Array
    Dim Actual As Variant   ' Actual Array
    Dim Result As Variant   ' Result Array
    Dim i As Long           ' CatCode Array Elements Counter
    Dim j As Long           ' Actual Array Elements Counter
    Dim k As Long           ' Result Array 1st Dimension (Rows) Elements Counter

    ' Write ranges to arrays.
    With ThisWorkbook.Worksheets(cSheet)
        Set rng = .Columns(cCol).Find(What:="*", LookIn:=xlFormulas, _
          SearchDirection:=xlPrevious)
        CatCode = .Range(.Cells(cFR, cCol), rng)
    End With
    With ThisWorkbook.Worksheets(aSheet)
        Set rng = .Columns(aCol).Find(What:="*", LookIn:=xlFormulas, _
          SearchDirection:=xlPrevious)
        Actual = .Range(.Cells(aFR, aCol), rng)
    End With
    Set rng = Nothing

    ' The following line assumes that all 'data is valid'. If not then
    ' Result Array will have empty elements at the end (probably no harm done,
    ' but definately 'not correct'.
    ' Resize Result Array (Same first dimension (rows) as Actual Array).
    ReDim Result(1 To UBound(Actual) + 1, 1 To 2) ' '+1' for headers
    ' Write headers to Result Array.
    Result(1, 1) = Head1
    Result(1, 2) = Head2
    ' Calculate and write data to Result Array.
    k = 2
    For i = 1 To UBound(CatCode)
        For j = 1 To UBound(Actual)
            If Actual(j, 1) Like CatCode(i, 1) & "*" Then
                Result(k, 1) = CatCode(i, 1)
                Result(k, 2) = Actual(j, 1)
                k = k + 1
            End If
        Next j
    Next i
    ' Note: The previous For Next Loop always loops through all elements
    ' of Actual Array allowing it to be unsorted.

    ' Erase arrays not needed anymore.
    Erase CatCode
    Erase Actual

    With ThisWorkbook.Worksheets(rSheet)
        ' Clear contents of columns of Result Range.
        .Range(rCel).Resize(.Rows.Count - Range(rCel).Row + 1, 2).ClearContents
        ' Define Result Range.
        Set rng = .Range(rCel).Resize(UBound(Result), UBound(Result, 2))
    End With

    ' Copy Result Array to Result Range.
    rng = Result

    ' Inform user.
    MsgBox "Transferred Result(" & UBound(Result) & "x" & UBound(Result, 2) _
      & ").", vbInformation, "Custom Message"

End Sub