Return matching values in other sheet according to multiple criteria

Question

Warning: Complex situation requires wall of text

What I have as data

In sheet A, I have alphanumerical numbers In column A and sometimes, suppliers in columns B, C, D.

 colA      colB   colC   colD

H-19328    SupA   SupB   SupA
H-12801    SupC   SupD
H-32829    
H-23123    SupB   SupC
.......    ....   ....   ....

In sheet B, I have alphanumerical numbers in column A, and 1 supplier in column B. I also have a bunch of other information in the next columns.

 colA      colB    colC   colD

H-19328    SupA   stuffs stuffs 
H-52601    SupA   stuffs stuffs
H-3279     SupA   stuffs stuffs
H-4987123  SupB   stuffs stuffs
.......    ....   ...... ......

In sheet A, the alphanumerical number is unique in the list. The numbers in sheet A may or may not have a matching number in sheet B and vice versa. Even when the number matches, the suppliers may or may not match.

What I want to do

For each number in sheet A, I want to check if sheet B holds that number with the associated supplier. For example, for the first number H-19328, I will check if sheet B has:

 colA      colB    colC   colD

H-19328    SupA   stuffs stuffs   < This could match twice as it was twice in A
H-19328    SupB   stuffs stuffs

I don't know if the number/supplier combo will match, and if it does, I don't know how many times it will match. I want to retrieve the values from sheet B in the other columns, C and D.

What I have as code

I put the values in column A of sheet A in a dictionnary. The keys are the numbers, and the Supplier information is in an array tied to each key. The dictionnary works well. The issue is not about the dictionnary, if you are not good with them you can still help me.

Right now I have a loop that matches every key + supplier to the sheet b list and returns how many times it matched. To dispel confusion, Dict_Sup is the dictionnary. Dict_sup.items(1) is an array containing suppliers. Dict_sup.items(1)(0) is the first entry of that array. Dict_sup.items(1)(supcount) is the last entry of that array.

For i = 0 To Dict_Sup.Count - 1
    For j = 0 To supcount 'supcount is the size of the array containing the suppliers
        nb_of_matches = TimesExtracted(Dict_Sup.Keys(i), Dict_Sup.Items(i)(j))   
    Next j
Next

The function TimesExtracted looks into sheet B (which is an extract, sheet name is SupDocs) and matches what I mentioned to look at the number of matches. Here it is:

Function TimesExtracted(Key As String, Sup As String) As Integer()
    Dim lastline As Integer
    Dim AllSupDocs As Range
    Dim SupDoc As Range

    lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row
    Set AllSupDocs = SupDocs.Range("E1:E" & lastline)

    For Each SupDoc In AllSupDocs
        If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then
              Timesextracted = TimesExtracted + 1
        End If
    Next
End Function

I would like to transform this function so that it would send the 'stuffs' on which it found matches, instead of sending the amount of matches. There are 3 'stuffs' values I want. I tried making it an Array function, but I was not successful in redimensioning the array to send back an appropriate amount of results;

Function TimesExtracted(Key As String, Sup As String) As String()
    Dim lastline As Integer
    Dim AllSupDocs As Range
    Dim SupDoc As Range
    Dim tmpArray(0) As String
    Dim j As Integer

    lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row
    Set AllSupDocs = SupDocs.Range("E1:E" & lastline)

    For Each SupDoc In AllSupDocs
        If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then
            ReDim Preserve tmpArray(UBound(tmpArray) To UBound(tmpArray) + 2) 'adds 2 places in the array
            tmpArray(j) = SupDoc(, 3).Value
            tmpArray(j + 1) = SupDoc(, 4)Value
            j = j + 2
        End If
    Next
    Timesextracted = tmpArray 'Doing this so I can redim 
End Function

Is there a better way to return the values I want? Am i making this way too complex? If both answers are no, then what do i need to modify in this last block for it to send an array with the following information

If only SupA matched in column A100:
    (C100.Value, D100.Value)

If supA matched in A100 and matched again in A110:
    (C100.Value, D100.Value, C110.Value, D110.Value)

Answer 1

It is pretty simple actually. I have commented the code but if you still have a problem understanding it then let me know :)

Const sep  As String = "|"

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet, WsRef As Worksheet
    Dim col As New Collection, itm
    Dim i As Long, j As Long, lRow As Long
    Dim aCell As Range

    Set wsI = Sheet1    '<~~ Sheet A as per your data
    Set WsRef = Sheet2  '<~~ Sheet B as per your data
    Set wsO = Sheet3    '~~< New Sheet for Output

    With wsI
        '~~> Find last row of col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> What the code does is joins Col A value in Sheet A
        '~~> First with Col B and then with Col C and then with
        '~~> Col D and stores them in a unique collection
        '~~> Looping from row 1 to last row
        For i = 1 To lRow
            '~~> Looping from Col B to Col D
            For j = 2 To 4
                sString = wsI.Cells(i, 1) & sep & wsI.Cells(i, j)
                On Error Resume Next
                col.Add sString, CStr(sString)
                On Error GoTo 0
            Next j
        Next i
    End With

    j = 1 '<~~ First Row in Output Sheet

    '~~> Looping through the unique collection
    For Each itm In col
        '~~> Extraction the alphanumerical value and finding it in Sheet B
        Set aCell = WsRef.Columns(1).Find(What:=Split(itm, sep)(0), LookIn:=xlValues, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
        '~~> If Found
        If Not aCell Is Nothing Then
            wsO.Cells(j, 1).Value = Split(itm, sep)(0)
            wsO.Cells(j, 2).Value = Split(itm, sep)(1)
            wsO.Cells(j, 3).Value = aCell.Offset(, 2)
            wsO.Cells(j, 4).Value = aCell.Offset(, 3)
            j = j + 1
        End If
    Next
End Sub

NOTE: If you have huge rows of data then I would recommend copy the data from SheetA and SheetB into separate arrays and then do all the above in memory so that the execution is faster.

---

Followup From comments

Is this what you are trying?

Sub Sample()
    Dim tmpAr As Variant

    tmpAr = TimesExtracted("H-19328", "SupA")

    If IsArray(tmpAr) Then
        For i = 1 To UBound(tmpAr)
            Debug.Print tmpAr(i, 1) & "," & tmpAr(i, 2)
        Next i
    Else
        Debug.Print tmpAr
    End If
End Sub

Function TimesExtracted(Key As String, Sup As String) As Variant
    Dim MyAr As Variant
    Dim wsRef As Worksheet, rngWsRef As Range
    Dim bCell As Range, oRange As Range
    Dim ListRange As Range

    TimesExtracted = "Not Found"

    Set wsRef = Sheet2  '<~~ Sheet B as per your data
    Set ListRange = wsRef.Columns(1)

    n = Application.WorksheetFunction.CountIf(ListRange, Key)

    If n <> 0 Then
       ReDim MyAr(n, 2)

       n = 1

       Set oRange = ListRange.Find(what:=Key, LookIn:=xlValues, _
       lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
       MatchCase:=False, SearchFormat:=False)

       If Not oRange Is Nothing Then
           Set bCell = oRange
                MyAr(n, 1) = oRange.Offset(, 2).Value
                MyAr(n, 2) = oRange.Offset(, 3).Value
                n = n + 1
           Do
               Set oRange = ListRange.Find(what:=Key, After:=oRange, LookIn:=xlValues, _
               lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
               MatchCase:=False, SearchFormat:=False)

               If Not oRange Is Nothing Then
                   If oRange.Address = bCell.Address Then Exit Do
                   MyAr(n, 1) = oRange.Offset(, 2).Value
                   MyAr(n, 2) = oRange.Offset(, 3).Value
                   n = n + 1
               Else
                   Exit Do
               End If
           Loop
           TimesExtracted = MyAr
       End If
    End If
End Function