Excel VBA函数根据列范围返回查找值

我是VBA的新手，需要社区在以下逻辑方面的帮助。 我有下表

我的实际数据表如下

我的预期产出如下：

我尝试对cat代码使用索引值，并尝试过，但我在这里被逻辑卡住，无法继续。谢谢你的帮助

注：实际数据不需要包含Catcode，例如，属于Catcode A的值在值中并不总是包含A。我想将两个CATCODE之间的所有值分类为它后面的cat代码。

基于列范围查找 调整常量部分中的值（例如，图纸名称可以完全相同，第一行或第一列可以不同等）

新版本 旧版本改进

---

普通的排序逻辑将在较长的字符串之前有较短的字符串，这意味着在Aa之前有A。在A3之后排序是一个复杂的因素，除非你有充分的理由，否则你应该避免。这里有一种方法。[1.]在相关列中找到最后一行[2.]在实际表中循环[3.]使用

LEFT（）

[4.]提取第一个字符和整个单词存储在字典或集合中[5.]对字典/集合进行排序[6.]导出到工作表按需添加注释。非常感谢您的帮助。修改了预期输出以提供更好的清晰度。@ceeka9388：您的意思是当有“A”时，此数据和所有以前的数据都是CatCode“A”？当有“B”时，这个和所有在“A”之前但之后的数据都是CatCode“B”？这太完美了。

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

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