Extract multiple match values without duplicates

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

1. In cell E1: =UNIQUE(A1:A10)
2. In cell F1: =TRANSPOSE(UNIQUE(FILTER(B1:B10,A1:A10=E1)))
3. 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...