Reputation: 775
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.
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
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