Excel 列出需要较长时间处理的唯一值公式

我有一个来自上一个问题的公式，它很好用。它列出了从B2开始的动态列A到列B的唯一值。通常A列有几千个值，因此处理需要很长时间。增加计算线程并没有节省很多时间。我正在寻找一个更好的方法或公式，可以节省我很多时间

=IFERROR（索引（A:A；聚合（15；6；行（$A$2:INDEX（A:A；MATCH（$zzz；A:A）））/（COUNTIF（$B$1:B1；$A$2:INDEX（A:A；MATCH（$zzz；A:A）））=0；1））；“”）

---

如您问题的评论中所述，使用新的“预官方”唯一函数或透视表可能是获取唯一值的最简单、最快速的方法。但是，如果要使用不需要按下按钮或使用更新版本的Excel的VBA函数，您可能需要尝试下面介绍的VBA函数“GetUniques”

这是如何使用该函数的示例：

要使用该功能，必须做3件事：

在VBA编辑器中添加对mscorlib.dll的引用（原因解释如下）

为VBA函数本身添加代码（最好是在它自己的模块中）

添加代码以处理工作簿的SheetCalculate事件（原因解释如下）

mscorlib.dll之所以使用“

ArrayList

”类（这比使用

Collection

类更容易），是因为它附带了排序方法（否则，我们必须实现快速排序过程）。为了避免后期绑定，我在VBA编辑器中添加了对此库的引用（位于我的计算机上的“C:\Windows\Microsoft.NET\Framework\v4.0.30319”）。有关如何使用此类的详细信息，请转到下面的链接：

VBA函数实际上在调用它的公式单元格之外写入值。由于Excel不能很好地实现这一点，因此需要一种变通方法。我尝试使用“

应用程序.评估”

”方法作为一种变通方法，这在很多地方都有建议，但由于某种原因，它对我不起作用。因此，我被迫使用SheetCalculate事件（正如在其他地方建议的那样）。简言之，函数本身不在调用方单元格外写入值，而是在“准队列”中为其保留一个“请求”，然后在Excel处理SheetCalculate事件时对其进行处理；此事件将在VBA函数完成执行后触发。此函数将第一个值写入公式单元格本身，其余值直接写入公式单元格下方

“GetUniques”函数有两个参数：

包含要处理的值的范围（我建议将整个列作为范围发送，除非有标题）

一个可选的“数据类型”字符串，允许函数将值转换为正确的数据类型（以避免在比较不同类型的值时出错）

可选的“数据类型”值可以是“L”（表示“长整数”）、“D”（表示“日期”）、“F”（表示浮点双精度）、“S”（表示不区分大小写的字符串）或“S2”（表示“区分大小写的字符串”）。无法转换的值将被忽略。如果未提供“数据类型”值，则不会尝试进行类型转换，但如果尝试在不同数据类型之间进行无效比较，则函数可能会出错

VBA函数的代码称为“GetUniques”，如下所示。此代码可以复制粘贴到其自身的模块：

Option Explicit

'This is the "commands queue" that is filled up in this module and is "executed" during the SheetCalculate event
Public ExtraCalcCommands As New Collection

Function GetUniques(ByVal dataRange As Range, Optional ByVal dataType As String = "") As Variant
  'Attempt to remove unused cells from the data range to make it smaller
  Dim dataRng As Range
  Set dataRng = Application.Intersect(dataRange, dataRange.Worksheet.UsedRange)

  'If the range is completely empty, simply exit
  If dataRng Is Nothing Then
    GetUniques = ""
    Exit Function
  End If

  'Read in all the data values from the range
  Dim values As Variant: values = dataRng.value

  'If the values do not form an array, it is a single value, so just return it
  If Not IsArray(values) Then
    GetUniques = values
    Exit Function
  End If

  'Get the 2-dimensional array's bounds
  Dim arrLb As Long: arrLb = LBound(values, 1)
  Dim arrUb As Long: arrUb = UBound(values, 1)
  Dim index2 As Long: index2 = LBound(values, 2) 'In the 2nd dimension, we only
                                                 '  care about the first column

  'Remember the original number of values
  Dim arrCount As Long: arrCount = arrUb - arrLb + 1
  'Since [values] is an array, we know that arrCount >= 2

  Dim i As Long

  'Using ArrayList based on ideas from https://excelmacromastery.com/vba-arraylist

  'Copy the values to an ArrayList object, discarding blank values and values
  '  that cannot be converted to the desired data type (if one was specified)
  Dim valuesList As New ArrayList
  Dim arrValue As Variant
  For i = arrLb To arrUb
    arrValue = values(i, index2)

    If (arrValue & "") = "" Then
      'Skip blank values
    ElseIf Not CouldConvert(arrValue, dataType) Then
      'This conversion may be necessary to ensure that the values can be compared against each other during the sort
    Else
      valuesList.Add arrValue
    End If
  Next

  Dim valuesCount As Long: valuesCount = valuesList.Count

  'Sort the list to easily remove adjacent duplicates
  If Not CouldSort(valuesList) Then
    GetUniques = "#ERROR: Could not sort - consider using the data type argument"
    Exit Function
  End If

  'Remove duplicates (which are now adjacent due to the sort)
  Dim previous As Variant
  If valuesCount > 0 Then previous = valuesList.Item(0)
  Dim current As Variant
  i = 1
  Do While i < valuesCount
    current = valuesList.Item(i)

    If ValuesMatch(current, previous, dataType) Then 'Remove duplicates
      valuesList.RemoveAt i
      valuesCount = valuesCount - 1
    Else
      previous = current
      i = i + 1
    End If
  Loop

  'Replace the removed items with empty strings at the end of the list
  '  This is to get back to the original number of values
  For i = 1 To arrCount - valuesCount
    valuesList.Add ""
  Next

  'Return the first value as the function result
  GetUniques = valuesList.Item(0) 'We know valuesList.Count=arrCount>=2

  'Write the rest of the values below
  valuesList.RemoveAt 0
  WriteArrayTo valuesList, Application.Caller.Offset(1, 0)
End Function

Private Function CouldSort(ByRef valuesList As ArrayList)
  On Error Resume Next
  valuesList.Sort
  CouldSort = Err.Number = 0
End Function

Private Function CouldConvert(ByRef value As Variant, ByVal dataType As String)
  CouldConvert = True

  If dataType = "" Then Exit Function

  On Error Resume Next
  Select Case dataType
    Case "L": value = CLng(value)
    Case "F": value = CDbl(value)
    Case "D": value = CDate(value)
    Case "S", "S2": value = value & ""
  End Select

  CouldConvert = Err.Number = 0
End Function

Private Function ValuesMatch(ByVal v1 As Variant, ByVal v2 As Variant, ByVal dataType As String) As Boolean
  On Error Resume Next
  Select Case dataType
    Case "S": ValuesMatch = StrComp(v1, v2, vbTextCompare) = 0
    Case "S2": ValuesMatch = StrComp(v1, v2, vbBinaryCompare) = 0
    Case Else: ValuesMatch = v1 = v2
  End Select
  If Err.Number <> 0 Then ValuesMatch = False
End Function

Private Sub WriteArrayTo(ByVal list As ArrayList, ByRef destination As Range)
  'This procedure does not do the actual writing but saves the "command" to do the writing in a "queue";
  '  this "commands queue" will be executed in the SheetCalculate event;
  'We cannot write to cells outside the UDF's formula whilst the function is being calculated
  '  because of Excel restrictions; that is why we must postpone the writing for later

  Dim coll As New Collection
  coll.Add "DoWriteList" 'Name of the procedure to execute
  coll.Add destination   '1st argument used by the procedure
  coll.Add list          '2nd argument used by the procedure
  ExtraCalcCommands.Add coll
End Sub

---

我希望以上内容能有所帮助，如果是的话，我希望这是对原始IFERROR公式的一种速度改进。我还希望SheetCalculate事件处理程序不会在包含许多公式和计算的密集工作簿中引起问题。

如果您可以通过Office Insiders程序访问它，您可以使用。否则VBA可能会更快。还是仅仅删除重复？一个数据透视表？电力查询？还是VBA…高级过滤器？@JvdV我创建了一个数据透视表，计算时间现在可能快了10倍。唯一的缺点是，它需要单击刷新按钮来更新透视表。我可以接受。非常感谢。

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
  Dim i&
  Do While ExtraCalcCommands.Count > 0
    Dim cmdColl As Collection: Set cmdColl = ExtraCalcCommands.Item(1)
    Select Case cmdColl.Item(1)
      Case "DoWriteList": DoWriteList cmdColl.Item(2), cmdColl.Item(3)
      'Other procedure names could go here in future
    End Select

    'Remove the processed "command" from the queue
    ExtraCalcCommands.Remove 1
  Loop
End Sub

Private Sub DoWriteList(ByRef destination As Range, ByVal list As ArrayList)
  destination.Resize(list.Count, 1).value = WorksheetFunction.Transpose(list.ToArray)
End Sub