Question

我是这个论坛和vba语言的新手，所以我希望得到一些指导。我有一张不同床单的工作簿，但现在只有3件重要。第一张和第三张表具有将在Sheet2中互连的数据。在Sheet1和Sheet3中，我有Sheet1_Sheet3_Test。这是第2页Sheet2_Test，它在第一个fase中全部为空，我想自动化它，因为我以前手动完成这项工作。在图像是我需要得到的。到目前为止，我有以下代码，它可以工作并填充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并按顺序返回所有值并填充表2中的A列。然后它将再次转到表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

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

2 个答案: