excel - 一次返回一个查找值和不同范围的多个对应值

Question

我是这个论坛和 vba 语言的新手，所以我希望得到一些指导。我有一个不同工作表的工作簿，但现在只有 3 个重要。第一张和第三张表包含将在 Sheet2 中互连的数据。
在 Sheet1 和 Sheet3 我有 Sheet1_Sheet3_Test .这是表 2 Sheet2_Test也就是说，首先是空的，我想自动化它，因为我之前是手动完成这项工作的。在图像中是我需要得到的。到目前为止，我有以下代码，它可以工作并填充 Sheet2 的 C 列。
但我在 A 列遇到问题。我试图简单地使用如下公式:

{=IF(A3=A2;INDEX(Sheet3!$A$3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B$3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A1)));INDEX(Sheet3!$A3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A$1))))}

问题是当 C 列中的文本更改时出现错误，现在我被卡住了。我不知道开发另一个宏是否会更好，或者我是否可以在公式中更改某些内容。

如果很难理解我在问什么，我很抱歉，但很难解释它。
我需要遍历 sheet1 中的每一行，例如:在 Sheet 1 中，我在第 3 行中有 INST - I_1 和 ID - AA。该公式在 sheet3 上搜索 AA 并按顺序返回所有值并填充 sheet 2 中的 A 列。然后它将再次转到 sheet 1 中的第 4 行并再次重复该过程，直到 Sheet1 上没有更多值。

Sub TestSheet2()

    Dim Rng As Range
    Dim InputRng As Range, OutRng As Range

    xTitleId = "Sheet1"

    Sheets("Sheet1").Select

    Set InputRng = Application.Selection
    On Error Resume Next
    Set InputRng = Application.InputBox("Select:", xTitleId, InputRng.Address, Type:=8)

    xTitleId = "Sheet2"

    Sheets("Sheet2").Select

    Set OutRng = Application.InputBox("Select:", xTitleId, Type:=8)
    Set OutRng = OutRng.Range("A1")

    For Each Rng In InputRng.Rows
        xValue = Rng.Range("A1").Value
        xNum = Rng.Range("C1").Value

        OutRng.Resize(xNum, 1).Value = xValue

        Set OutRng = OutRng.Offset(xNum, 0)

    Next
    End Sub

Answer 1

根据提供的图像，我能够遍历几个数组并想出这个。

Sub fill_er_up()
    Dim a As Long, b As Long, c As Long
    Dim arr1 As Variant, arr2() As Variant, arr3 As Variant

    With Worksheets("sheet1")
        With .Range(.Cells(3, 1), .Cells(Rows.Count, 2).End(xlUp))
            .Cells.Sort key1:=.Columns(2), order1:=xlAscending, _
                        key2:=.Columns(1), order2:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
            arr1 = .Cells.Value2
        End With
    End With

    With Worksheets("sheet3")
        With .Range(.Cells(3, 1), .Cells(Rows.Count, 3).End(xlUp))
            .Cells.Sort key1:=.Columns(3), order1:=xlAscending, _
                        key2:=.Columns(1), order2:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
            arr3 = .Cells.Value2
        End With
    End With

    For a = LBound(arr1, 1) To UBound(arr1, 1)
        For c = LBound(arr3, 1) To UBound(arr3, 1)
            'Do While arr3(c, 3) <> arr1(a, 2): c = c + 1: Loop
            If arr3(c, 3) = arr1(a, 2) Then
                b = b + 1
                ReDim Preserve arr2(1 To 3, 1 To b)
                arr2(1, b) = arr3(c, 1)
                arr2(2, b) = arr3(c, 3)
                arr2(3, b) = arr1(a, 1)
            End If
        Next c
    Next a

    With Worksheets("sheet2")
        Dim arr4 As Variant
        arr4 = my_2D_Transpose(arr4, arr2)
        .Cells(3, 1).Resize(UBound(arr4, 1), UBound(arr4, 2)) = arr4
    End With

    Erase arr1: Erase arr2: Erase arr3: Erase arr4

End Sub

Function my_2D_Transpose(a1 As Variant, a2 As Variant)
    Dim a As Long, b As Long
    ReDim a1(1 To UBound(a2, 2), 1 To UBound(a2, 1))
    For a = LBound(a2, 1) To UBound(a2, 1)
        For b = LBound(a2, 2) To UBound(a2, 2)
            a1(b, a) = Trim(a2(a, b))
        Next b
    Next a
    my_2D_Transpose = a1
End Function

我将 id 添加到 sheet2 中结果的第二列。这似乎是填充空白单元格的合理方法。