如何从多个查找值中返回多个项目
我正在从2010年的Excelmacros工作。
我有一个名为“数据”的第一个表，有他们的属性的责任规则。
<Rule name Source label Criteria etc… until column V RGC-EC-01 AU-DU AUDIT = RGC-EC-01 DU-FICT FICT R RGC-EC-01 NNE-ECC CONTRACT E RGC-EC-02 DU-FICT FICT > RGC-EC-02 LO-DT DIT <> etc… 第二张纸被命名为“结果”。 此时除标题外（与数据表相同）没有数据。 这张表的目的是根据我正在查找的规则名称来复制表单DATA中的所有数据。
规则名称出现在列W（OUTCOME表），有几个取决于和我在找什么（另一个电子表格不担心）。 我想报告从colum W到OUTCOME表的匹配数据。
因此，在一个命令中，如何从多个查找值（多个规则（Range cell））复制多行（一个规则具有多行）。
防爆
W2 = RGC-EC-01
W3 = RGC-EC-02
我想检索上面列出的所有值，等等。
我已经做了一个数组公式，但它的重点是一个值（在这个例子中的单元格W2）
=IFERROR(INDEX(DATA!A$2:A$7000;SMALL(ROW(DATA!$A$2:$A$7000)*(DATA!$A$2:$A$7000=$W$2);COUNTIF(DATA!$A$2:$A$7000;"<>"&$W$2)+ROW()-1)-1);"")
我将这个公式集成到了单元格A2的OUTCOME SHEET中，然后扩展它来捕获规则名称的下一个属性（Source，Label等）。 它正确地报告W2上的规则的所有行，但正如我所说，我被限制在一个查询值（一个规则）。
macros应该循环这个数组公式，以整合W列中的所有值，而列W不是空的，并将数据复制到结果表中。
我已经search了2天，但由于缺乏VBA的技能，我仍然无法做到。
所有的帮助，欢迎！ 谢谢，克里斯
如果你想保持你的数组公式，这是你的愿望：
{=IFERROR(INDEX(DATA!A:A,SMALL(IF(COUNTIF($W$2:$W$10,DATA!$A$2:$A$1000),ROW($2:$1000)),ROW()-1)),"")}
编辑
我假设你对如何通过VBA实现这一点感兴趣。我会为你提供一个简短的代码，它可以做你想做的。
Sub copyByFilter() With Sheets("DATA") Intersect(.[A:V], .UsedRange).AutoFilter 1, Application.Transpose([OUTCOME!W2:W100]), 7 Intersect(.[A:V], .UsedRange).Copy [OUTCOME!A1] .[A:V].AutoFilter End With End Sub
首先，它使用Excel中内置的自动filter来显示符合条件的值。 然后它复制整个范围并粘贴到您的目的地（格式化，也是在相同的顺序，但没有你不想要的行）。 作为最后一步，它会从“数据”中清除自动filter 。 这就是说：如果您手动使用自动filter ，那么它将在执行后消失（但可以再次打开）。 ;）
没有“循环”/“variables”/“如果”或类似的东西。 只有less量的function（按照它们出现的顺序）：
-
Sub -
With -
Sheets -
Intersect -
[]（方括号） -
UsedRange -
AutoFilter -
Application.Transpose* -
Range.Copy
* Application.Transpose还有另一个“奇怪”的行为，可以在@ Jon49的答案中看到。
编辑2
如果自动filter是不可能的，那么通过所有行似乎无法避免…我会告诉你如何实现一个数组公式如：
COUNTIF(OUTCOME!W2:W***,DATA!A2:A***)
***需要被replace为适当的行号。 这是（对于DATA ）：
Range("A" & Rows.Count).End(xlUp).Row
如果在一个INDEX使用，vba中的Evaluate函数可以返回一个数组，跳过这个部分来检查每个细胞无数次（这也是更快的）。 把所有东西放在一起，我们以类似的东西结束：
Sub copyByFilter2() Dim temp As Variant, xList As Range, i As Long, xRows As Long With Sheets("DATA") xRows = .Range("A" & .Rows.Count).End(xlUp).Row temp = Evaluate("INDEX(COUNTIF(OUTCOME!" & Sheets("OUTCOME").Range("W2", Sheets("OUTCOME").Range("W" & .Rows.Count).End(xlUp)).Address & ", DATA!" & .Range("A1:A" & xRows).Address & "),)") Set xList = .Range("A1:V1") For i = 2 To xRows If temp(i, 1) Then Set xList = Union(xList, Intersect(.Range("A:V"), .Rows(i))) Next xList.Copy Sheets("OUTCOME").Cells(1, 1) End With End Sub
因为整个EDIT2是通过电话完成的，所以可能会有拼写错误。 此外，新function的链接列表将被跳过。
如果您仍然有任何疑问或问题，那就问/告诉我:)
我知道的公式是可以执行的，这是他的作者的“lookupconcat”信用。
如果你想忙，这里有一个VBA解决scheme。 按ALT + F11打开VB编辑器。 在左边的窗口中find“VBA Project”下的“This Workbook”，双击它并粘贴下面的代码：
Option Explicit Sub CopyRules() Dim cell As Object Dim rowLoop As Long Dim ruleLoop As Long Dim writeLoop As Long Dim rulesToFind As Variant Dim rowsToCopy As Variant Dim copyCount As Long 'Get the unique rules in the selected range into a variant array For Each cell In Selection If Len(cell.value) > 0 Then rulesToFind = FncAddtoVariant(rulesToFind, cell.value) End If Next cell 'Get the row numbers that match this criteria into a variant array Do While ruleLoop <= UBound(rulesToFind) 'We start at row #2 because we assume headers in row #1 For rowLoop = 2 To ActiveSheet.UsedRange.Rows.Count If Range("A" & rowLoop).value = rulesToFind(ruleLoop) Then rowsToCopy = FncAddtoVariant(rowsToCopy, CStr(rowLoop)) End If Next rowLoop ruleLoop = ruleLoop + 1 Loop 'Copy the rows to the different sheet For copyCount = 2 To UBound(rowsToCopy) + 2 Sheets("DATA").Select Rows(rowsToCopy(copyCount - 2) & ":" & rowsToCopy(copyCount - 2)).Select Selection.Copy Sheets("OUTCOME").Select Rows(ActiveSheet.UsedRange.Rows.Count + 1 & ":" & ActiveSheet.UsedRange.Rows.Count + 1).Select ActiveSheet.Paste Next copyCount End Sub Private Function FncAddtoVariant(arr As Variant, value As String) As Variant Dim i As Integer If Not FncArrayInitialised(arr) Then ReDim arr(0) i = 0 Else If Not FncPreviouslyAdded(arr, value) Then i = UBound(arr) + 1 ReDim Preserve arr(i) End If End If arr(i) = value FncAddtoVariant = arr End Function Private Function FncArrayInitialised(val) As Boolean On Error GoTo FncArrayInitialisedError Dim i If Not IsArray(val) Then GoTo exitRoutine i = UBound(val) FncArrayInitialised = True exitRoutine: Exit Function FncArrayInitialisedError: Select Case Err.Number Case 9 'Subscript out of range GoTo exitRoutine Case Else Debug.Print Err.Number & ": " & Err.Description, _ "Error in Initialized()" End Select Debug.Assert False Resume End Function Private Function FncPreviouslyAdded(checkArr As Variant, item As String) As Boolean Dim i As Long Dim found As Boolean Do While i <= UBound(checkArr) And found = False If item = checkArr(i) Then found = True i = i + 1 Loop FncPreviouslyAdded = found End Function
您应该然后分配一个button这个macros： https ： //support.microsoft.com/en-gb/kb/141689
完成此操作后，可以在工作表的“A”列中select一个范围，然后单击macrosbutton，并将所有相关列复制到另一个工作表中。