Extract multiple match values without duplicates - excel

Question

I have a set of matching values as shown:
The input is a table with Order number in the first column and dates in the seventh column.
I would like to extract all the matching dates from the seventh column and display only the 'unique dates' in the columns against each matching order value.
If there are no matching values in the input, it should return blank values in output.
I use Excel 2016. The inputs are in sheet 2.
I managed to get the dates with array index formula but it is slow with large data.

Answer 1

If you have access to the new array functions UNIQUE & FILTER then:
Using the sample data below
In cell E1: =UNIQUE(A1:A10)
In cell F1: =TRANSPOSE(UNIQUE(FILTER(B1:B10,A1:A10=E1)))
Then drag the formula from F1 down to the last cell which will populate your desired table.

Answer 2

Please, try the next VBA solution. It should be very fast, using two dictionaries and arrays, mostly working in memory. It will return the processed result starting from "J2" cell. It can return anywhere, you should only change "J2" cell with the cell range you need, even being in another sheet:
Sub extractUniqueValues_Dat()
Dim sh As Worksheet, lastR As Long, arr, arrIt, arrFin, Z As Long
Dim dict As Object, dictI As Object, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:G" & lastR).value 'place the range to be processed in an array, for faster iteration
Set dict = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
For i = 1 To UBound(arr) 'iterate between the array rows and load the dictionary:
If Not dict.Exists(arr(i, 1)) Then 'if the key does not exist:
Set dictI = CreateObject("Scripting.Dictionary") 'set a new dictionary
dictI.Add arr(i, 7), vbNullString 'create a key of the new dictionary using first Date occurrence
dict.Add arr(i, 1), dictI 'create a dictionary key as Value and add the new dictionary as item
If dictI.count > Z Then Z = dictI.count 'extract maximum number of Date occurrences
Else
dict(arr(i, 1))(arr(i, 7)) = vbNullString 'if the key of the item dictionary does not exist it is added, with an empty item
If dict(arr(i, 1)).count > Z Then Z = dict(arr(i, 1)).count 'extract maximum number of Date occurrences
End If
Next i
ReDim arrFin(1 To dict.count, 1 To Z + 1) '+ 1, to make place for the dictionary key (in first column)
'fill the arrFin array:
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i) 'place the main dictionary key in the first column of the final array
For k = 1 To dict.Items()(i).count
arrFin(i + 1, 1 + k) = dict.Items()(i).Keys()(k - 1) 'place each date (extracted from the item dictionary keys) in the following columns
Next k
Next i
'build the header:
Dim arrH: arrH = Evaluate("TRANSPOSE(ROW(1:" & Z & "))")
arrH = Split("Match Value|Data " & Join(arrH, "|Data "), "|")
'drop the final aray content and apply a little formatting:
With sh.Range("J2").Resize(UBound(arrFin), UBound(arrFin, 2))
.value = arrFin
With .rows(1).Offset(-1)
.value = arrH
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
Please send some feedback after testing it.
Edited:
Please, test the next version. It will work even if the customer orders will not be unique (in K:K column)... This code will also extract only unique values from the mentioned range. It will also check if there are values in the processed sheet which cannot be found in K:K, and returns in the sheet being processed, starting from "M1". Please, use the real sheet where K:K necessary column exists, when set shK sheet!
Private Sub extractUniqueValues_Dat()
Dim shK As Worksheet, lastRK As Long, sh As Worksheet, lastR As Long, arr, arrK, arrIt, arrFin, Z As Long
Dim dict As Object, dictI As Object, dictK As Object, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in B:B
arr = sh.Range("B2:H" & lastR).Value 'place the range to be processed in an array, for faster iteration
Set shK = Worksheets("sheet KK") 'use here the necessary sheet (with values in K:K)!!!
lastRK = shK.Range("K" & shK.rows.count).End(xlUp).row 'last row in K:K
arrK = shK.Range("K2:K" & lastRK).Value
Set dictK = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
Set dict = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
'place the UNIQUE values in a dictionary, as keys and all unique date, for all accurrences in an item array:
For i = 1 To UBound(arr) 'iterate between the array rows and load the dictionary:
If Not dict.Exists(arr(i, 1)) Then 'if the key does not exist:
Set dictI = CreateObject("Scripting.Dictionary") 'set a new dictionary
dictI.Add arr(i, 7), vbNullString 'create a key of the new dictionary using first Date occurrence
dict.Add arr(i, 1), dictI 'create a dictionary key as Value and add the new dictionary as item
If dictI.count > Z Then Z = dictI.count 'extract maximum number of Date occurrences
Else
dict(arr(i, 1))(arr(i, 7)) = vbNullString 'if the key of the item dictinary does not exist it is added, with an empty item
If dict(arr(i, 1)).count > Z Then Z = dict(arr(i, 1)).count 'extract maximum number of Date occurrences
End If
Next i
'place the UNIQUE vales from K:K column, only as keys:
For i = 1 To UBound(arrK)
dictK(arrK(i, 1)) = vbNullString
Next i
ReDim arrFin(1 To dictK.count, 1 To Z + 3) '+ 1, to make splace for the dictionary key (in first column)
'fill the arrFin array:
For i = 0 To dictK.count - 1
arrFin(i + 1, 1) = dictK.Keys()(i) 'place the main dictionary keyi in the first column of the final array
If dict.Exists(dictK.Keys()(i)) Then
For k = 1 To dict(dictK.Keys()(i)).count
arrFin(i + 1, 3 + k) = dict(dictK.Keys()(i)).Keys()(k - 1) 'place each date (extracted from the item dictionary keys) in the following columns
Next k
End If
Next i
'check if there are missing values from sheet with processed data:
Dim arrMiss, KK As Long, boolMiss As Boolean
ReDim arrMiss(dict.count)
For i = 0 To dict.count - 1
If Not dictK.Exists(dict.Keys()(i)) Then
arrMiss(KK) = dict.Keys()(i): KK = KK + 1
End If
Next i
'build the header:
Dim arrH: arrH = Evaluate("TRANSPOSE(ROW(1:" & Z & "))")
arrH = Split("Match Value|x|y|Data " & Join(arrH, "|Data "), "|")
'drop the final aray content and apply a little formatting:
With sh.Range("M2").Resize(UBound(arrFin), UBound(arrFin, 2))
.CurrentRegion.Value = "" 'if the previous return dropped more rows than the actual one...
.Value = arrFin
With .rows(1).Offset(-1)
.Value = arrH
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
If KK > 0 Then
ReDim Preserve arrMiss(KK - 1)
MsgBox "Missing Values: " & vbCrLf & Join(arrMiss, vbCrLf), vbInformation, "Please, check..."
boolMiss = True
End If
If Not boolMiss Then MsgBox "Ready..."
End Sub
Send some feedback after testing it, please...