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

boblovejoyce

爬文了30分鐘~看到的資訊都是刪除重複的居多
也有保留重複資料的文章,例如:
http://forum.twbts.com/viewthrea ... hlight=%AD%AB%BD%C6

如下圖片~因為是依照座標X和Y,所以想要留下重複的@@
反而不重複的,變成不想要的
這樣可以處理嗎?能否給個意見方式

目前是使用將XY的儲存格 &起來後,然後再用大家敘述的countif,然後在排序在篩選~
可是這樣過程似乎很攏長~@@

下載 (55.31 KB)

2015-9-23 23:39

保留重複的資料.rar (7.17 KB)

下載次數: 8

2015-9-23 23:33

GBKEE

回復 1# boblovejoyce
試試看

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

複製代碼

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:

下載 (79.44 KB)

2023-4-27 15:47

執行結果:

下載 (86.71 KB)

2023-4-27 15:48

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), A, Y, i&, j%, T1$, T2$, T3$, TT$, N%
Dim xR As Range, Ra As Range, Sh As Worksheet, xBook As Workbook
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([C1], Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3): TT = T2 & "/" & T3
   A = Y(TT): N = Y(TT & "|R"): N = N + 1
   If Not IsArray(A) Then A = Crr
   For j = 1 To 3: A(N, j) = Brr(i, j): Next
   Y(TT) = A: Y(TT & "|R") = N
Next
[K:M].ClearContents: [K1:M1] = [{"型號","座標X","座標Y"}]: N = 2
For Each A In Y.KEYS
   If InStr(A, "|") Then GoTo i01
   If Y(A & "|R") = 1 Then GoTo i01
   Cells(N, "K").Resize(Y(A & "|R"), 3) = Y(A)
   N = N + Y(A & "|R")
i01: Next
Set Y = Nothing: Erase Brr, Crr
End Sub