Dim mSht As Worksheet
Dim mRng1 As Range, mRng2 As Range, E As Range
Dim mDic1 As Object
Dim mDic2 As Object
Dim mData1(), mData2()
Dim s1%, s2%
Dim key1, key2
Set mDic1 = CreateObject("scripting.dictionary")
Set mDic2 = CreateObject("scripting.dictionary")
Set mSht = Worksheets(1)
With mSht
Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
For Each E In mRng1
If Not mDic1.Exists(E.Value) Then
mDic1.Add (E.Value), E.Value
Else
ReDim Preserve mData1(s1)
mData1(s1) = E.Value
s1 = s1 + 1
End If
Next
For Each E In mRng2
If Not mDic2.Exists(E.Value) Then
mDic2.Add (E.Value), E.Value
Else
ReDim Preserve mData2(s2)
mData2(s2) = E.Value
s2 = s2 + 1
End If
Next
.Range("e6") = "重複數值"
.Range("e6:f6").Merge
.Range("e7").Resize(s1) = Application.Transpose(mData1)
.Range("f7").Resize(s2) = Application.Transpose(mData2)
'mKey2 = mDic2.Keys
'mItem2 = mDic2.Items
Erase mData1
Erase mData2
s1 = 0
s2 = 0
For Each key1 In mDic1.Keys
If key1 <> mDic2(key1) Then
ReDim Preserve mData1(s1)
mData1(s1) = key1
s1 = s1 + 1
End If
Next
For Each key2 In mDic2.Keys
If key2 <> mDic1(key2) Then
ReDim Preserve mData2(s2)
mData2(s2) = key2
s2 = s2 + 1
End If
Next
Dim mSht As Worksheet
Dim mRng1 As Range, mRng2 As Range, E As Range
Dim mDic1 As Object
Dim mDic2 As Object
Dim mData1(), mData2()
Dim s%, s1%, s2%
Set mDic1 = CreateObject("scripting.dictionary")
Set mDic2 = CreateObject("scripting.dictionary")
Set mSht = Worksheets(1)
With mSht
Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
For Each E In mRng1
If E.Value <> "" Then
mDic1(E.Value) = mDic1(E.Value) + 1
End If
Next
For Each key1 In mDic1.Keys
If mDic1(key1) > 1 Then
ReDim Preserve mData1(s1)
mData1(s1) = key1
s1 = s1 + 1
End If
Next
For Each E In mRng2
If E.Value <> "" Then
mDic2(E.Value) = mDic2(E.Value) + 1
End If
Next
For Each key2 In mDic2.Keys
If mDic2(key2) > 1 Then
ReDim Preserve mData2(s2)
mData2(s2) = key2
s2 = s2 + 1
End If
Next
If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay 要改成
If s > 0 Then Cells(2, 10 - i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
欠缺數值欄位才會對應到。作者: Andy2483 時間: 2023-6-15 15:11
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
執行前:
[attach]36591[/attach]
執行結果:
[attach]36592[/attach]
Option Explicit
Sub TEST()
Dim Brr, Va&, Vb&, Z, Q, i&, Ra&, Rb&, M&, Ta$, Tb$
[E7:F65536,I2:J65536].ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([A1].CurrentRegion, [A:B])
For i = 1 To UBound(Brr)
Ta = Brr(i, 1): Tb = Brr(i, 2): Brr(i, 1) = "": Brr(i, 2) = ""
If Ta = "" Then GoTo i01 Else Va = Z(Ta)
If Va = 1 Then
Ra = Ra + 1
Brr(Ra, 1) = Ta
M = IIf(M < Ra, Ra, M)
Else:
Z(Ta) = 1
End If
i01: If Tb = "" Then GoTo i02 Else Vb = Z("|" & Tb)
If Vb = 1 Then
Rb = Rb + 1
Brr(Rb, 2) = Tb
M = IIf(M < Rb, Rb, M)
Else
Z("|" & Tb) = 1
End If
i02: Next
If M > 0 Then [E7].Resize(M, 2) = Brr
ReDim Brr(1 To UBound(Brr), 1 To 2)
Ra = 0: Rb = 0: M = 0
For Each Q In Z.KEYS
If InStr(Q, "|") = 0 Then
If Z.Exists("|" & Q) = Empty Then
Rb = Rb + 1
Brr(Rb, 2) = Q
End If
ElseIf Z.Exists(Mid(Q, 2)) = Empty Then
Ra = Ra + 1
Brr(Ra, 1) = Mid(Q, 2)
End If
If M < Ra Then M = Ra
If M < Rb Then M = Rb
Next
If M > 0 Then [I2].Resize(M, 2) = Brr
Set Z = Nothing: Erase Brr
End Sub
