我正在嘗試開發一個函式，該函式將獲取包含重復值的結果陣列并回傳僅包含重復值的陣列。下面的代碼確實有效，但我想知道是否有更優雅/更短的解決方案？
Sub test()
Dim allFruits(9) As String, manyFruits() As String
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = duplicates(allFruits())
End Sub
Function duplicates(allFound() As String)
Dim myFound() As String
Dim i As Integer, e As Integer, c As Integer, x As Integer
Dim Comp1 As String, Comp2 As String
Dim found As Boolean
If Len(Join(allFound)) > 0 Then 'Check string array initialised
If UBound(allFound) > 0 Then
For c = 0 To UBound(allFound) 'Pass ONLY the duplicates
Comp1 = allFound(c)
If Comp1 > "" Then
For x = c 1 To UBound(allFound)
Comp2 = allFound(x)
If Comp1 = Comp2 Then
found = True
ReDim Preserve myFound(0 To i)
myFound(i) = Comp1
i = i 1
For e = x To UBound(allFound) 'Delete forward instances of found item
If allFound(e) = Comp1 Then
allFound(e) = ""
End If
Next e
Exit For
End If
Next x
End If
Next c
Else 'Just one found
ReDim myFound(0 To 0)
myFound(0) = allFound(0)
found = True
End If
End If
duplicates = myFound
End Function
uj5u.com熱心網友回復：
雙詞典
作為字串（完全相同的功能）
Sub test1()
Dim allFruits(9) As String, manyFruits() As String
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = Duplicates1(allFruits())
Debug.Print Join(manyFruits, vbLf)
End Sub
Function Duplicates1(StringArray() As String) As String()
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim n As Long
For n = LBound(StringArray) To UBound(StringArray)
If sDict.Exists(StringArray(n)) Then
dDict(StringArray(n)) = Empty
Else
sDict(StringArray(n)) = Empty
End If
Next n
If dDict.Count = 0 Then Exit Function
Set sDict = Nothing
Dim arr() As String: ReDim arr(0 To dDict.Count - 1)
Dim Key As Variant
n = 0
For Each Key In dDict.Keys
arr(n) = Key
n = n 1
Next Key
Duplicates1 = arr
End Function
作為變體（更短但不同，請參閱' ***）
Sub test2()
Dim allFruits(9) As String, manyFruits() As Variant ' *** here
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = Duplicates2(allFruits())
Debug.Print Join(manyFruits, vbLf)
End Sub
Function Duplicates2(StringArray() As String) As Variant ' *** here
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim n As Long
For n = LBound(StringArray) To UBound(StringArray)
If sDict.Exists(StringArray(n)) Then
dDict(StringArray(n)) = Empty
Else
sDict(StringArray(n)) = Empty
End If
Next n
Duplicates2 = dDict.Keys
End Function
uj5u.com熱心網友回復：
短距離通過FilterXML()
這種方法
nm使用名稱屬性 ( )將基本陣列 allFruits 轉換為格式良好的 xml 內容，并且- 在所有節點上應用 XPath 運算式，僅通過以下方式過濾具有兄弟姐妹的節點
"fruits/fruit[(@nm = following-sibling::fruit/@nm)]/@nm"
除了顯式參考水果之外，您還可以從 XPath 開始，//fruit[..."其中雙斜杠表示在任何層次結構級別進行搜索。
Function MoreThanOne(arr)
'Purp: get only fruits with multiple occurrencies
'Note: reads top to bottom returning the last(!) attribute @nm
' based on the condition of no following fruit sibling,
'a) create a wellformed xml content string
Dim content As String
content = _
"<fruits><fruit nm='" & _
Join(arr, "'/><fruit nm='") & _
"'/></fruits>"
'b) define XPath expression
Dim XPth As String
XPth = "/fruits/fruit[(@nm = following-sibling::fruit/@nm)]/@nm" ' multiple occurrencies
'c) apply FilterXML function
Dim x: x = Application.FilterXML(content, XPth)
'd) return result(s)
MoreThanOne = Application.Transpose(x)
Select Case VarType(x)
Case vbError
MoreThanOne = Array("Nothing found")
Case vbString
MoreThanOne = Array(x)
Case Else
MoreThanOne = Application.Transpose(x)
End Select
End Function
示例呼叫
Sub testMoreThanOne()
Dim allFruits(9) As String, manyFruits() As Variant
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = MoreThanOne(allFruits)
Debug.Print Join(manyFruits, vbLf) ' ~~> plum|apple
End Sub
通過上述陣列連接創建的 xml 結構的架構
<fruits>
<fruit nm='plum'/>
<fruit nm='apple'/>
<fruit nm='orange'/>
<fruit nm='banana'/>
<fruit nm='melon'/>
<fruit nm='plum'/>
<fruit nm='kiwi'/>
<fruit nm='nectarine'/>
<fruit nm='apple'/>
<fruit nm='grapes'/>
</fruits>
邊注
當然，您可能只想通過否定括號中的 XPath 條件來獲得唯一性
XPth = "/fruits/fruit[not(@nm = following-sibling::fruit/@nm)]/@nm"
uj5u.com熱心網友回復：
我的解決方案...
Sub FindDuplicates()
Dim VarDat As Variant
Dim lngz As Long, lngz2 As Long, lngF As Long
Dim objDict As Object
Dim b As Boolean
With Sheet1
Set objDict = CreateObject("Scripting.Dictionary")
VarDat = .Range("A1:A20").Value2
For lngz = 1 To UBound(VarDat, 1)
For lngz2 = lngz 1 To UBound(VarDat, 1)
If VarDat(lngz, 1) = VarDat(lngz2, 1) Then
b = True
Exit For
End If
Next lngz2
If b = True Then
If objDict.Exists(VarDat(lngz, 1)) = False Then
objDict.Add VarDat(lngz, 1), 0
End If
b = False
End If
Next lngz
.Range("D:D").Clear
.Range("D1:D" & objDict.Count) = Application.Transpose(objDict.keys)
End With
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/429216.html