Question

我正在研究excel 2010中的宏。

我有第一张名为“DATA”的表格，其中有属性的责任规则。

<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…

第二张名为OUTCOME。此时除了标题（与DATA表相同）之外没有数据。本表的目的是根据我正在寻找的规则名称复制工作表DATA中的所有数据。

规则名称存在于W列（OUTCOME表）中，有几个依赖和我正在寻找（另一个电子表格不用担心）。我想报告关于从colum W到OUTCOME表的值的匹配数据。

所以它是如何在一个命令中从多个查找值（多个规则（范围单元格））复制多行（一个规则有多行）。

实施例
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);"")

我在OUTCOME SHEET的单元格A2上集成了这个公式，然后我扩展它以从规则名称中捕获下一个属性（Source，Label等...）。它正确地报告了W2上存在的规则中的所有行，但正如我所说，我只限于一个查找值（一条规则）。

宏应循环此数组公式以集成W列中的所有值，而列W不为空并在结果表上复制数据。

我从2天开始搜索，但由于缺乏VBA技能，我仍然无法实现。

欢迎所有帮助！谢谢问候，克里斯

Answer 1

如果你想继续使用你的数组公式，这就是你想要的：

{=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中的内置自动过滤器来仅显示符合条件的值。然后它复制整个范围并将其粘贴到您的目的地（使用格式和相同的顺序，但没有您不想要的行）。最后一步，它会清除“DATA”中的自动过滤器。也就是说：如果您手动使用自动过滤器，那么它将在执行后消失（但您可以再次打开它）。 ;）

没有“循环”/“变量”/“如果是”或类似的东西。只需少量功能（按照它们出现的顺序）：

Sub

With

Sheets

Intersect

[] (square brackets)

UsedRange

AutoFilter

Application.Transpose *

Range.Copy

* Application.Transpose的另一个“奇怪”行为可以在@ Jon49的回答中看到here。

编辑2

如果无法自动过滤，那么在所有行中运行似乎无法避免......我将向您展示如何使用如下数组公式实现：

COUNTIF(OUTCOME!W2:W***,DATA!A2:A***)

***需要替换为相应的行号。这是（对于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是通过电话完成的，所以可能会有拼写错误。此外，还将跳过新功能的链接列表。

如果您仍有任何问题或疑问，请告诉我：）

Answer 2

我知道的公式可以执行此作为"lookupconcat"作者的作品。

Answer 3

如果你想忙碌的话，这是一个VBA解决方案。按ALT + F11打开VB编辑器。在左侧窗口中，找到＆＃34;此工作簿＆＃34;在＆＃34; VBA项目＆＃34;下，双击它并粘贴在以下代码中：

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

然后您应该为此宏指定一个按钮：https://support.microsoft.com/en-gb/kb/141689

完成此操作后，您只需在＆＃34; A＆＃34;中选择一个范围即可。工作表的列，然后单击宏按钮，它应将所有相关列复制到另一个工作表。

如何从多个查找值返回多个项目

3 个答案: