[發問]刪除不重複的資料,只留下重複的資訊

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2015-9-24 08:01 | 顯示全部帖子

回復 1# boblovejoyce
試試看

Option Explicit
Sub EX()
Dim D As Object, DD As Object, E As Variant, Ar(), S As String, i As Integer
Set D = CreateObject("SCRIPTING.DICTIONARY")
'Dictionary 物件與 PERL 相關陣列全等。可以是任何型式的資料的項目被儲存在陣列中。每個項目都與一個唯一的關鍵字相關。該關鍵字用來取出單個項目，通常是整數或字串，可以是除陣列外的任何型態。
Set DD = CreateObject("SCRIPTING.DICTIONARY")
With Range("A1").CurrentRegion
'CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
For Each E In .Rows
S = E.Cells(1, 2) & "-" & E.Cells(1, 3)
If D.Exists(S) Then '字典物件的關鍵字存在
Ar = D(S)
ReDim Preserve Ar(1 To 3, 1 To UBound(Ar, 2) + 1)
'Preserve 選擇性引數。當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
For i = 1 To 3
Ar(i, UBound(Ar, 2)) = E.Cells(1, i)
Next
D(S) = Ar
DD(S) = Ar
Else
D(S) = Application.Transpose(E)
End If
Next
End With
For Each E In DD.ITEMS '字典物件的項目
With Range("F" & Rows.Count).End(xlUp).Offset(1)
Ar = Application.Transpose(E)
.Resize(UBound(Ar), 3) = Ar
End With
Next
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 手心向下是助人，手心向上是求人；助人快樂，求人痛苦。