一次返回一个Lookup Value的MULTIPLE对应值和不同的范围

我在这个论坛和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列中的文本发生变化时，我得到一个错误，现在我卡住了。 我不知道开发另外一个macros是否会更好，或者我可以在公式中改变一些东西。

如果我很难理解我在问什么，但是很难解释它，我感到抱歉。 我需要遍历sheet1中的每一行，例如：在表1中我有第3行，INST – I_1和ID – AA。 该公式在sheet3上searchAA并按顺序返回所有值，并填充sheet 2中的column 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

我能够用下面的代码重新创build结果表格，在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