- 帖子
- 231
- 主題
- 55
- 精華
- 0
- 積分
- 293
- 點名
- 0
- 作業系統
- winxp
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 來自
- KEELUNG
- 註冊時間
- 2010-7-24
- 最後登錄
- 2018-8-28
|
你好：
你的提問讓我也有學習的機會。
謝謝你！
請試試下列是否可適用。
Sub aa()
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
.Range("i1") = "A欄缺之數值"
.Range("j1") = "B欄缺之數值"
.Range("i2").Resize(s1) = Application.Transpose(mData1)
.Range("j2").Resize(s2) = Application.Transpose(mData2)
End With
Set mDic1 = Nothing
Set mDic2 = Nothing
Set mRng1 = Nothing
Set mRng2 = Nothing
End Sub |
|
發表於 2011-10-8 15:30
| 