Nick
Nick

Reputation: 775

Searching each item on a list and returning all Matches

I have the following Example Raw Data set containing a list of chemicals and the suppliers providing these. This exists on another sheet and I users to be able to pull through the information via a search as shown below.

enter image description here

I appreciate that I can use FILTER to return multiple results in a dynamic array however this doesnt work to search for multiple chemicals.

Essentially I just wish to allow a user to create a list of values and from the raw data matching results for suppliers and the original raw material searches for are pulled through for each.

I'm not sure if this is achievable using just formulas or if this will require vba but if anyone could comment that would be great. Using VBA I suppose I could loop through the search list for each and populate the next cell down depending on whether the current cell is blank or not. Ideally however I would like to have the data populate as the list is entered and not have to click a button for a macro to run.

Any suggestions are appreciated.

Upvotes: 0

Views: 531

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, test the next code. It takes the list from range "H4" to the last row on H:H and placed the processed result in columns I:J, starting from the fourth row:

Sub ListOccurrences()
   Dim sh As Worksheet, lastR As Long, arr, arrList, dict As Object
   Dim arrIt, arrFin, mtch, i As Long, El, k As Long
   
   Set sh = ActiveSheet  'use here the sheet you need
   lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row on the B:B column
   arrList = sh.Range("H4:H" & sh.Range("H" & sh.rows.count).End(xlUp).row).value 'the 2D array list
   arrList = Application.Transpose(arrList)            'the 1D array list
   arr = sh.Range("B4:C" & lastR).value              'put the range to be processed in an array
   Set dict = CreateObject("Scripting.dictionary")  'create a Scripting dictionary to keep the values per key
   For i = 1 To UBound(arr)                             'iterate between array rows
        mtch = Application.match(arr(i, 1), arrList, 0) 'check if the search strinig exists in the list array
        If Not IsError(mtch) Then                          'if it exist in the list:
            If Not dict.Exists(arr(i, 1)) Then              'if a dictionary key not exist:
                dict.Add arr(i, 1), arr(i, 2)                   'create the key with its value
            Else
                dict(arr(i, 1)) = dict(arr(i, 1)) & "|" & arr(i, 2) 'add to the existing key a new value, separated by "|"
            End If
        End If
   Next i
   'process the dictionary items:
   ReDim arrFin(1 To 2, 1 To UBound(arr)) 'redim the final array at the level of the range to be process number of rows
   For Each El In dict.Keys                       'iterate betwen the dictionary keys
        arrIt = Split(dict(El), "|")                 'split each key value by "|"
        If IsArray(arrIt) Then                     'if there are more than a value:
            For i = 0 To UBound(arrIt)
                k = k + 1
                arrFin(2, k) = El: arrFin(1, k) = arrIt(i) 'place the key and the value in the final array
            Next i
        Else
            k = k + 1
            arrFin(2, k) = El: arrFin(1, k) = arrIt       'place the key and all its values in the final array
        End If
    Next
    If k > 0 Then
        ReDim Preserve arrFin(1 To 2, 1 To k)        'keep in the final array only the filled array elements (not empty)
        arrFin = Application.Transpose(arrFin)        'transpose the array to return exactly what needed
    End If
    sh.Range("I4").Resize(k, 2).value = arrFin       'drop the result at once
End Sub

I commented all code lines which may not be clear enough about they do.

Please, send some feedback and confirm that you understand the code logic...

Upvotes: 1

Related Questions