基于列范围返回LOOKUP值的VBA函数

Question

我对VBA来说还比较陌生，因此在以下逻辑上需要社区的帮助。我有下表

我的实际数据表如下

我的预期输出如下：

我尝试对cat代码使用索引值并尝试过，但是我在这里陷入逻辑困境，无法继续。感谢您的帮助。

注意：实际数据不必包含Catcode，例如，属于CatCode A的值不一定会在该值中包含A。我会将两个目录之间的所有值归类到其后的目录。

Answer 1

基于列范围的查找

调整constants部分中的值（例如，工作表名称可以全部相同，第一行或第一列可以不同，等等）。>>

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 rCell 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

    ' 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

    ' Define Result Range.
    With ThisWorkbook.Worksheets(rSheet)
        Set rng = .Range(rCell).Resize(UBound(Result), UBound(Result, 2))
    End With

    ' Copy Result Array to Result Range.
    rng = Result

    ' Inform user.
    MsgBox "Finished transferring data.", vbInformation, "Custom Message"

End Sub