VBA Function to Return LOOKUP Values Based on Column Range - excel

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