来自一维数组的唯一值，无需迭代

Posted 2023-02-27

【中文标题】来自一维数组的唯一值，无需迭代

【英文标题】：Unique values from 1D-array, without iteration

【发布时间】：2020-04-28 04:52:39

【问题描述】：

冒着成为话题的风险，我决定分享一些代码，Q&A-style。如果普遍认为这会偏离主题，我很乐意在需要时删除。

---

_背景

我们能否从任何一维数组中检索所有唯一值，或者将Range 对象转换为一维数组，而无需遍历其元素？就我而言，普遍的共识是必须遍历不同的元素，最好的方法是使用字典或集合来存储唯一值。Here 是我发现的非常适合这个目的。

---

_问题

那么如何从一维数组中检索唯一元素，例如：

Dim arr As Variant: arr = Array("A", "A", "C", "D", "A", "E", "G")

结果数组的位置：

"A", "C", "D", "E", "G"

【问题讨论】：

我的投票是，这是一个有效的问答。

***.com/help/self-answer 并且当您提出问题时，会出现一个“回答您自己的问题 - 分享您的知识，问答式”复选框以表明它很好。由于技术上不可能在不迭代的情况下在典型的顺序计算机上找到唯一值，我认为标题有点误导实际问题。

【参考方案1】：

真正需要的所有代码都只是几行代码：

Sub test()

Dim arr As Variant: arr = Array("A", "A", "C", "D", "A", "E", "G")
With Application
    uniques = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False))
End With

End Sub

上面将返回一个一维数组，返回我们原始数组中的所有唯一元素：

---

_说明：

检索所有这些值的行看起来很密集，所以让我们把它分成几部分：

---

Application.Match 能够在其参数中使用数组。所以基本上我们在看：.Match("A","A","C","D","A","E","G","A","A","C","D","A","E","G",0)。然后返回的数组将是：1,1,3,4,1,6,7，这实际上是找到每个值的第一个位置。这一结果将成为我们进一步发展的基础。

---

我们可以在我们的代码中看到第三个.Match，我们基本上需要告诉以下内容：.Match(1,2,3,4,5,6,7,1,1,3,4,1,6,7,0)。第一个参数是上面高亮代码检索到的。

.Evaluate("ROW(1:" & UBound(.Match(arr, arr, 0)) & ")") 将返回来自 1-7 的值数组，Application.Transpose 将返回一维数组。

---

最后一步将返回一个包含错误的数组，但是代码不会中断，因为我们使用的是Application 而不是WorksheetFunction。结果数组看起来像1,Error 2042,3,4,Error 2042,6,7。现在的重点是摆脱 Error 值。

这样做的方法是通过Application.IfError，它将评估数组并将所有错误值更改为给定的字符串值。在我们的例子中，我使用了管道符号。由用户决定一个足够独特的符号，它不会出现在原始数组的任何元素中。所以经过评估。我们当前的数组看起来像：1,|,3,4,|,6,7。

---

现在我们检索了一个带有管道符号的数组，我们希望它们出来！一个快速的方法是使用Filter 函数。 Filter 返回一个包含或不包含符合我们条件的元素的数组（取决于第三个参数中的 TRUE 或 FALSE）。

所以基本上我们想要返回一个像这样的数组：Filter(<array>, "|", False)。生成的一维数组现在看起来像：1,3,4,6,7。

---

在这一点上我们有点。我们只需要从原始数组中切出正确的值。为此，我们可以使用Application.Index。我们只想告诉.Index 我们对哪些行感兴趣。为此，我们可以加载我们之前找到的一维数组。所以代码看起来像：.Index(arr1, <array>, 1) 这将产生一个一维数组："A","C","D","E","G"

---

_结论：

你有它。一行（不仅仅是一个操作）从另一个一维数组没有迭代检索唯一值的一维数组。此代码可用于任何以arr 声明的一维数组。

有用吗？我不是 100% 确定，但我终于达到了我在项目中尝试的目标。生成的数组可以立即用于您需要在其中使用唯一值的任何任务中。

_{比较：字典与 Application.Methods：}

对Range(A1:A50000)中的随机项进行比较，性能确实受到了打击。特此迭代字典与非迭代 Application.Methods 方法在 1000 个项目步骤中的时间比较。在 1000 项和每 10000 项标记的结果下方（以秒为单位）：

| Items     | Dictionary    | Methods       |
|-------    |------------   |-------------  |
| 1000      | 0,02          | 0,03          |
| 10000     | 0             | 0,88          |
| 20000     | 0,02          | 3,31          |
| 30000     | 0,02          | 7,3           |
| 40000     | 0,02          | 12,84         |
| 50000     | 0,03          | 20,2          |

使用的Dictionary 方法：

Sub Test()

Dim arr As Variant: arr = Application.Transpose(Range("A1:A50000"))
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

Dim x As Long

For x = LBound(arr) To UBound(arr)
    dict(arr(x)) = 1
Next x

Dim uniques As Variant: uniques = dict.Keys

End Sub

结论： 与更常见的Dictionary 做法相比，此方法最多可处理 1000 个项目，其处理时间大致相等。在任何更大的事情上，迭代（通过内存）总是会击败方法方法！

我敢肯定，@ScottCraner 的 shown 等新动态数组函数会更加限制处理时间。

【讨论】：

干得好，解释也很清楚。你正在整理一个很好的东西库——也许你可以把它们放在某个地方。

恕我直言，使用字典的解决方案更加清晰和简单。甚至您提供的链接中的代码也可以缩短并赢得清晰。所以我不会在这篇文章中寻求这个解决方案。

@Storax，我必须 100% 同意你的看法。然而，我并不想说出哪种程序更好或不更好。我的想法是，普遍的共识是，无需迭代就不可能检索唯一值。话虽如此，一旦你得到这条线，你需要改变的只是arr变量。

@JvdV：是的，没错，字典解决方案需要循环，而你不需要。

【参考方案2】：

使用新的动态数组函数，它可以简化为：

Sub test()

Dim arr As Variant: arr = Array("A", "A", "C", "D", "A", "E", "G")
With Application
    Dim uniques as variant
    uniques = .Transpose(.Unique(.Transpose(arr)))
End With

End Sub

新的Uniques Formula需要一个垂直数组，可以是2d的。它的行为类似于Range.RemoveDuplicate，但无法选择列。

【讨论】：

不顾一切，这是我一开始尝试的。只是意识到我还没有幸运地接触到它。但是，是的，一旦我这样做，这将踢我的示例数字对接 =) + 对于这个优雅的选择。

很高兴看到越来越多的新功能被投入使用。

@ScottCraner 仅供参考 发布了 Office 365 解决方案的替代方案无需需要转置两次

【参考方案3】：

通过FilterXML()接近

为了丰富上面的各种精细解决方案，我通过新的工作表函数FilterXML()演示了一种方法。

Sub testUniqueItems()
'   Purp: list unique items
'   Site: https://***.com/questions/59683363/unique-values-from-1d-array-without-iteration
    Dim arr As Variant: arr = Array("A", "A", "C", "D", "A", "E", "G")
'[1]get uniques
    Dim uniques
    uniques = UniqueXML(arr)
'[2]display in Immediate Window: A,A,C,D,A,E,G => A,C,D,E,G
    Debug.Print Join(arr, ",") & " => " & _
                Join(uniques, ",")
End Sub

Function UniqueXML(arr, Optional Delim As String = ",")
  ' Purp: return unique list of array items
  ' Note: optional argument Delim defaulting to colon (",")
  ' Help: https://docs.microsoft.com/de-de/office/vba/api/excel.worksheetfunction.filterxml
  ' [1] get array data to xml node structure (including root element)
    Dim wellformed As String
    wellformed = "<root><i>" & Join(arr, "</i><i>") & "</i></root>"
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' [2] define XPath string searching unique item values
  ' Note: c.f. udf: https://***.com/questions/58677041/vba-excel-how-to-display-non-equal-values-in-an-excel-array/58685756#58685756
  ' ------------------------------------------------
  ' //i                    ... all <i> node values after the DocumentElement
  ' [not( .=preceding::i)] ... only if not preceded by siblings of the same node value
  ' ------------------------------------------------
    Dim myXPath As String
    myXPath = "//i[not( .=preceding::i)]"
  ' [3a] get (delimiter separated) unique list
    UniqueXML = Evaluate("=TEXTJOIN(""" & Delim & """,,FILTERXML(""" & wellformed & """, """ & myXPath & """))")
  ' [3b] return array
    UniqueXML = Split(UniqueXML, Delim)
End Function

相关链接

MS Help

Display non equal values in an Excel array

警告

请注意，工作表函数 FilterXML() 可以从 vers 中使用。 2016+，但 TextJoin 仅在版本中。 2019+（感谢@FaneDuru 为 cmets 提供：-）

此外，您还必须了解评估的限制。仅 255 个字符（感谢 @JvDv）。

为了克服这两个障碍，我对上述功能进行了重新设计，以便在 2016+ 版本中也可以使用。

自 2020 年 8 月 20 日起修改功能/编辑

Function UniqueXML(arr, Optional Delim As String = ",")
  ' Purp: return unique list of array items
  ' Note: optional argument Delim defaulting to colon (",")
  ' Help: https://docs.microsoft.com/de-de/office/vba/api/excel.worksheetfunction.filterxml
  ' [1] get array data to xml node structure (including root element)
    Dim wellformed As String
    wellformed = "<root><i>" & Join(arr, "</i><i>") & "</i></root>"
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' [2] define XPath string searching unique item values
  ' Note: c.f. udf: https://***.com/questions/58677041/vba-excel-how-to-display-non-equal-values-in-an-excel-array/58685756#58685756
  ' ------------------------------------------------
  ' //i                    ... all <i> node values after the DocumentElement
  ' [not( .=preceding::i)] ... only if not preceded by siblings of the same node value
  ' ------------------------------------------------
    Dim myXPath As String
    myXPath = "//i[not( .=preceding::i)]"
   
  ' [3] get "flat" 1-dim array (~> one-based!)
    Dim tmp As Variant
    tmp = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath))
'  ' [3a] optional redim as zero-based array
'    ReDim Preserve tmp(LBound(tmp) - 1 To UBound(tmp) - 1)
        
  ' [4] return function result
    UniqueXML = tmp
End Function

【讨论】：

Nice =)，但要清楚评估的限制。仅 255 个字符

我尝试了上面的代码，UniqueXML = Evaluate("=TEXTJOIN... 返回Error 2029（Excel 2016 Professional Pro - 64 位）...

@FaneDuru，似乎单个代码行 UniqueXML = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath)) 替换部分 [3a] 和 [3b] 解决了版本控制问题；你能验证一下吗：-;

是的。经过测试，它可以工作。你可以修改代码，提到它在 2016 年也可以工作。

更好... :)

【参考方案4】：

应用 Unique() 函数而不进行双重换位 (Office 365)

作为@ScottCraner 的 Office 365 解决方案的补充，无需转置两次：

Sub testUniques()
Dim arr:     arr = Array("A", "A", "C", "D", "A", "E", "G")  ' example data
Dim uniques: uniques = Application.Unique(arr, True)         ' return function result
'optional display in VB Editor's immediate window
    Debug.Print Join(arr, ",") & " ~> " & Join(uniques, ",") ' A,A,C,D,A,E,G ~> A,C,D,E,G
End Sub

对附加参数by_col的解释

由于Unique function reference，它的语法是UNIQUE(array,[by_col],[exactly_once])，其中

"the by_col 参数是指示如何比较的逻辑值。 TRUE 将相互比较列并返回唯一的列。"

将by_col 参数设置为True 允许将数组项相互比较，因为它们被视为“平面”一维数组中的“列”。