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

Question

我是这个论坛和 vba 语言的新手，所以我希望得到一些指导。我有一个不同工作表的工作簿，但现在只有 3 个重要。第一张和第三张表包含将在 Sheet2 中互连的数据。 在 Sheet1 和 Sheet3 中，我有 Sheet1_Sheet3_Test。这是 Sheet 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中结果的第二列。这似乎是填充空白单元格的合理方法。

      

Answer 2

我能够使用下面的代码重新创建您的结果表，过滤Sheet3 上的范围。

Option Explicit

Sub MergeIDs()
    Dim instSh As Worksheet
    Dim compfSh As Worksheet
    Dim mergeSh As Worksheet
    Dim inst As Range
    Dim compf As Range
    Dim merge As Range
    Dim lastInst As Long
    Dim lastCompf As Long
    Dim allCompf As Long
    Dim i As Long, j As Long
    Dim mergeRow As Long

    '--- initialize ranges
    Set instSh = ThisWorkbook.Sheets("Sheet1")
    Set compfSh = ThisWorkbook.Sheets("Sheet3")
    Set mergeSh = ThisWorkbook.Sheets("Sheet2")
    Set inst = instSh.Range("A3")
    Set compf = compfSh.Range("A2")
    Set merge = mergeSh.Range("A3")
    lastInst = instSh.Cells(instSh.Rows.Count, "A").End(xlUp).Row
    allCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row

    '--- clear destination
    mergeSh.Range("A:C").ClearContents
    merge.Cells(0, 1).Value = "COMPF"
    merge.Cells(0, 3).Value = "INST"

    '--- loop and build...
    mergeRow = 1
    For i = 1 To (lastInst - inst.Row + 1)
        '--- set the compf range to autofilter
        compfSh.AutoFilterMode = False
        compf.Resize(allCompf - compf.Row, 3).AutoFilter
        compf.Resize(allCompf - compf.Row, 3).AutoFilter Field:=3, Criteria1:=inst.Cells(i, 2).Value
        '--- merge the filtered values with the inst value
        lastCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row
        For j = 1 To (lastCompf - compf.Row)
            merge.Cells(mergeRow, 1).Value = compf.Cells(j + 1, 1).Value
            merge.Cells(mergeRow, 3).Value = inst.Cells(i, 1).Value
            mergeRow = mergeRow + 1
        Next j
    Next i

End Sub