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

问题描述 投票：0回答：3

我正在处理 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 中的所有数据。

规则名称出现在 W 列（结果表）中，有几个取决于我正在寻找的内容（另一个电子表格不用担心）。 我想报告有关 W 列到结果表的值的匹配数据。

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

例如
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 上，然后扩展它以捕获规则名称中的下一个属性（源、标签等...）。它正确地报告了 W2 上存在的规则中的所有行，但正如我所说，我仅限于一个查找值（一条规则）。

宏应循环此数组公式，以在 W 列不为空时整合 W 列中的所有值，并将数据复制到结果表上。

我已经找了两天了，但由于缺乏VBA技能，我仍然无法成功。

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

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

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

* 

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

编辑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都是通过电话完成的，所以可能会有错别字。新函数的链表也将被跳过。

如果您还有任何疑问或问题，请询问/告诉我:)

0
投票

我知道可用于执行此操作的公式是“lookupconcat”归功于他的作者。

0
投票

如果您想忙碌起来，这里有一个 VBA 解决方案。按 ALT + F11 打开 VB 编辑器。在左侧窗口中，找到“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

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

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

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.