4个回答
6
使用新的动态数组函数，可以简化为：
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
新的唯一性公式需要一个垂直数组，可以是二维的。它类似于
Range.RemoveDuplicate，但无法选择列。
- Scott Craner
3
尽管面临重重困难，这是我最初尝试的。只是意识到我还没有足够的运气来访问它。但是，是的，一旦我做到了，这将会击败我的示例数字化屁股 =）+ 这是一个优雅的替代方案。 - JvdV
非常高兴看到越来越多的新功能示例被投入使用。 - BigBen
@ScottCraner FYI，我发布了一个替代你的Office 365解决方案的方法，无需两次转置。 - T.M.
6
实际上，所需的所有代码只有几行：
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将使其返回为1D数组。
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)。结果1D数组现在看起来像：{1,3,4,6,7}。
Application.Index。我们只需告诉.Index我们感兴趣的行即可。为此，我们可以加载我们之前找到的1D数组。因此，代码将如下所示：.Index(arr1，<array>，1)，这将导致一个1D数组：{"A"，"C"，"D"，"E"，"G"}。
结论：
就是这样。只需一行代码（不止一个操作）即可从另一个1D数组中检索唯一值的1D数组，无需迭代。此代码可用于任何使用arr声明的1D数组。
有用吗？我不确定100％，但我终于在我的项目中达到了我想要的结果。生成的数组可以立即在需要使用唯一值的任何任务中使用。
比较：字典与Application.Methods：
对Range(A1:A50000)中的随机项进行比较，性能确实受到影响。以下是1000个项目步骤中迭代字典与非迭代Application.Methods方法之间的时间比较。下面是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 |
使用字典方法：
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我确信使用新的动态数组功能会更加受限，这已经由@ScottCraner 展示 过了。
- JvdV
4
2干得好，解释非常清晰。你正在组合一些不错的库 - 也许你可以把它们放在一起。 - SJR
3依我之见，使用字典的解决方案更清晰简单。即使在您提供的链接中的代码也可以缩短并提高清晰度。因此，我不会在此帖子中采用此解决方案。 - Storax
@Storax，我完全同意你的观点。然而，我的意图并不是告诉大家哪种方法更好或更差。我的想法是，普遍共识是在没有迭代的情况下无法检索唯一值。话虽如此，一旦你得到了这行代码，你只需要改变
arr变量即可。 - JvdV1@JvdV：是的，使用字典解决方案需要循环，而你的不需要。 - Storax
2
使用FilterXML()方法的途径
为了丰富以上优秀解决方案的多样性，我展示了一种使用新工作表函数FilterXML()的方法。
Sub testUniqueItems()
' Purp: list unique items
' Site: https://dev59.com/hLjoa4cB1Zd3GeqPAo82
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://learn.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://stackoverflow.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
相关链接
注意事项
请注意，工作表函数FilterXML()仅适用于2016年及以上版本，而TextJoin仅适用于2019年及以上版本（感谢@FaneDuru的评论）。
此外，您需要了解评估的限制。仅限255个字符（感谢@JvDv）。
为了克服这两个障碍，我重新设计了上述函数，使其也适用于2016年及以上版本。
修改后的函数 /截至2020-08-20
Function UniqueXML(arr, Optional Delim As String = ",")
' Purp: return unique list of array items
' Note: optional argument Delim defaulting to colon (",")
' Help: https://learn.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://stackoverflow.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
- T.M.
8
1不错 =)，但要充分意识到评估的限制。仅限255个字符。 - JvdV
糟糕...至少我现在知道问题出在哪里了。 - FaneDuru
1@FaneDuru，看起来单行代码
UniqueXML = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath)) 可以替换 [3a] 和 [3b] 部分，解决版本问题；你能验证一下吗 :-; - T.M.1是的。 已经测试过并且运行正常。 你可以适应代码，并提到它也适用于2016年。 - FaneDuru
1更好的是... :) - FaneDuru
显示剩余3条评论
2
在Office 365中应用Unique()函数时不需要进行双重转置
作为对@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函数的参考资料，其语法为UNIQUE(array,[by_col],[exactly_once])，其中
"by_col参数是一个逻辑值，用于指示如何进行比较。 TRUE将对列进行比较并返回唯一的列。"
将by_col参数设置为True，可以将数组项彼此进行比较，因为它们被视为“列”在“平面”的1维数组中。
- T.M.
网页内容由stack overflow 提供, 点击上面的可以查看英文原文，
原文链接
原文链接