How to return Multiple items from multiple lookup value

Question

I’m working on a macro from excel 2010.

I have a first sheet named “DATA”, there are accountability rules with theirs attributes.

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

The second sheet is named OUTCOME. At this moment except the titles (same as DATA sheet) there is no data. The aim to this sheet is to copy all the data from the sheet DATA according to the Rule name I’m looking for.

The Rule name are present to the column W (OUTCOME sheet) and there are several depending and what I’m looking for (another spreadsheet don’t worry about that). I would like to report the matching data regarding the value from colum W to OUTCOME sheet.

So it’s how to copy multi row (one rule has multiple row) from multiple lookup value (multiple rules (Range cell) in one command.

Ex
W2=RGC-EC-01
W3=RGC-EC-02
I want to retrieve all the value listed above and so on.

I’ve made an array formula but it’s focus on ONE VALUE (in this example the cell 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);"")

I integrated this formula on the cell A2 from OUTCOME SHEET then I extend it to catch the next attribute (Source, Label etc...) from the rule name. It correctly reports all the rows from the rule present on W2 but as I said I’m limited to one lookup value (one rule).

The macro should loop this array formula to integrate all the value from column W while column W is not empty and copy data on the outcome sheet.

I’ve searched since 2 days but due to the lack of VBA skills I’m still unable to make it.

All help is welcome ! Thanks Regards, Chris

Answer 1

If you want to stay with your array-formula, this is what you desire:

{=IFERROR(INDEX(DATA!A:A,SMALL(IF(COUNTIF($W$2:$W$10,DATA!$A$2:$A$1000),ROW($2:$1000)),ROW()-1)),"")}

EDIT

I assume that you are interested on how to achieve this via VBA.I will provide you a short code which will do all you want.

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

First, it uses the build-in Auto Filter from excel to show only the values which match your criteria. Then it copies the whole range and paste it to your destination (with formatting and also in the same order, but without the lines you do not want). And as last step, it clears the Auto Filter from your "DATA". That said: if you are using Auto Filter manually, then it will be gone after execution (but you can turn it on again). ;)

No "loops" / "variables" / "if's" or anything like that. Just a small amount of functions (in the order they appear):

• Sub
• With
• Sheets
• Intersect
• [] (square brackets)
• UsedRange
• AutoFilter
• Application.Transpose*
• Range.Copy

* There is another "strange" behavior of Application.Transpose which can be seen here at the answer of @Jon49.

EDIT 2

If auto filter is not possible, then running through all lines may seem impossible to avoid... I'll show you how to achive this with an array formula like:

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

The *** need to be replaced with the appropriate row number. This is (for DATA):

Range("A" & Rows.Count).End(xlUp).Row

If used within an INDEX the Evaluate function in vba can return an array which skips the part to check for every cell countless times (this also is faster). Putting everything together we end with something like that:

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

Because the whole EDIT2 was done by phone, there may be typos in it. Also the linked list for the new functions will be skipped.

If you still have any questions or problems, then just ask/tell me :)

Answer 2

The formula I know is available to perform this is "lookupconcat" credits to his author.

Answer 3

Here's a VBA solution if you want to get busy. Press ALT + F11 to open up the VB editor. In the window on the left, locate "This Workbook" under "VBA Project", double-click it and Paste in the following code:

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

You should then assign a button this Macro: https://support.microsoft.com/en-gb/kb/141689

Once this is done, you can just select a range in the "A" column of your sheet and then click the macro button and it should copy all the relevant columns into the other sheet.