提取多个匹配值而不重复

Question

我有一组匹配值，如图所示：

输入是一个表格，第一列是订单号，第七列是日期。

我想从第七列中提取所有匹配的日期，并仅针对每个匹配的订单值显示列中的“唯一日期”。
如果输入中没有匹配的值，它应该在输出中返回空白值。

我使用 Excel 2016。输入在表 2 中。

我设法使用数组索引公式获取日期，但使用大数据时速度很慢。

Answer 1

如果您可以访问新的数组函数UNIQUE 和FILTER，那么：

---

使用下面的示例数据

1. 在单元格 E1 中：=UNIQUE(A1:A10)
2. 在单元格 F1 中：=TRANSPOSE(UNIQUE(FILTER(B1:B10,A1:A10=E1)))
3. 然后将公式从F1 拖到最后一个单元格，该单元格将填充您想要的表格。

Answer 2

请尝试下一个 VBA 解决方案。它应该非常快，使用两个字典和数组，主要在内存中工作。它将返回从“J2”单元格开始的处理结果。它可以在任何地方返回，您应该只使用您需要的单元格范围更改“J2”单元格，即使在另一张表中：

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

请在测试后发送一些反馈。

已编辑：

请测试下一个版本。即使客户订单不是唯一的（在 K:K 列中），它也会起作用...此代码还将仅从提到的范围中提取唯一值。它还将检查已处理的工作表中是否有在 K:K 中找不到的值，并返回正在处理的工作表中，从“M1”开始。请，当设置shK sheet 时，使用存在 K:K 必要列的真实表格！

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

请在测试后发送一些反馈，请...