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

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

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

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

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

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

2^#

發表於 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元的贊助,人人有能力.

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

3^#

發表於 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP