標題: [發問] 清除重覆資料,只存留1筆資料 [打印本頁]

---

作者: linsurvey2005    時間: 2016-10-24 12:34     標題: 清除重覆資料,只存留1筆資料

本帖最後由 linsurvey2005 於 2016-10-24 12:43 編輯

請問資料比對
核對B欄,C欄,D欄都相同,才刪除重複資料,資料整理後只要存留1筆資料

[attach]25621[/attach]

---

作者: starbox520    時間: 2016-10-24 13:19

回復 1# linsurvey2005

EXCEL->資料 ->移除重複

---

作者: linsurvey2005    時間: 2016-10-24 13:48

回復 2# starbox520


感謝回覆
因為資料B C D欄同時相同情況,屬於1筆資料
但全部資料只能存在1筆,所以我沒辦法這樣子處理
請問有其他方式嗎?

---

作者: rouber590324    時間: 2016-10-24 14:20

如下為版內前輩之作品.試試

Sub ab()
    Dim arr As Variant
    Dim t As Range
    Dim s As New Collection
    Dim i, j As Long
    Dim myRng As Range
    j = [B65536].End(xlUp).Row
    Set myRng = Range("B1:B" & j)
    On Error Resume Next
    For Each t In myRng
        s.Add Item:=Range(t, t.Offset(0, 2)), key:=CStr(t)
    Next
    ReDim arr(1 To s.Count)
    For i = 1 To s.Count
        [f65536].End(xlUp).Offset(1, 0).Resize(, 3) = s(i).Value
    Next
End Sub

---

作者: linsurvey2005    時間: 2016-10-24 14:41

回復 4# rouber590324

謝謝回覆
執行之後會有誤刪的情形,如下說明:
因為1筆資料 有"編號" "E" "N" "ELE"(1列)
所以 B C D 三個欄位Matc才清除重複資料

如果只比對B欄位,那麼C D欄位沒有Match情況下,資料可能誤刪
請教可有他山

---

作者: rouber590324    時間: 2016-10-24 16:55

我會創造一欄將  "E"&"N"&"ELE" 資料串一欄
然後以如上程式比對不重覆秀出.
已16:54-要下班啦-明日休假-無時間修改程式-自己試試啦

---

作者: GBKEE    時間: 2016-10-24 19:58

回復 6# rouber590324

試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 2) As Range
   
4.      Set Rng(1) = ActiveSheet.Range("a1").CurrentRegion  '資料所在的範圍
   
5.      Set Rng(2) = ActiveSheet.Cells(1, Columns.Count - Rng(1).Columns.Count)
   
6.      With Rng(1)
   
7.         .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("B1:D1"), Unique:=True
   
8.         'Rng(1)的進階篩選:,  範圍中的 B:D 欄,不重複的資料
   
9.         .Copy Rng(2)
   
10.         .AdvancedFilter xlFilterInPlace    '全部資料顯示
    
11.         .Cells.Clear
    
12.        End With
    
13.        Rng(2).CurrentRegion.Copy Rng(1)(1)
    
14.        Rng(2).Clear
    
15. End Sub

複製代碼

---

作者: linsurvey2005    時間: 2016-10-24 22:49

回復 7# GBKEE


G大好
執行後狀況很奇怪
原始資料A:D欄 複製到B:E欄
A欄資料留下原始的幾個編號
感覺沒有比對

我需要的資料是點位坐標與高程資料
因為座標不能重複 因此需要刪除重複點位
可是有些點位的E值會一模一樣,因此要比對N值,又可能E值跟N值都一模一樣,所以必須比對ELE值
以上

---

作者: hcm19522    時間: 2016-10-25 10:23

http://blog.xuite.net/hcm19522/twblog/225435151
參考~
http://blog.xuite.net/hcm19522/twblog/458258396

---

作者: 准提部林    時間: 2016-10-26 11:51

編號78與5只有C.D欄相同, 為何只保留5???
VBA問題最好上傳附檔!!

---

作者: greetingsfromtw    時間: 2016-10-26 23:20

回復 10# 准提部林

同意淮提部林前輩所言,

也請允許小弟冒昧提點看法,發言有不當處請不吝指正,小弟一定改進.

小弟以為,
提供附檔的理由之一在於解答者不需再手動自己鍵入資料去進行測試,省去麻煩.
板上前輩願意無償提供解答,提問的板友提供附檔,應不是太大困難.

理由之二在於有時不提供附檔,真的容易造成誤會,因每人想事情看事情的角度不同,
若有附檔,可能會更易理解問題所在.

其實前面回文已有不少高手前輩們回覆精妙解答,
未能答到板友想要的效果,可能就是無附檔之故導致產生對問題的誤解,
若有提供附檔,想必能免去此一遺憾.

以上所言僅供參考,不當處請海涵.

小弟斗膽,
附上小弟修改自淮提部林前輩所寫之程式碼後的版本及檔案,絕非小弟所原創,特此聲明.

vba功力太差,改得不好,希望有所幫助,有不當處也請前輩們務必指點一二,感謝.
本想寫註解,但因目前對前輩所寫的原本程式碼還不敢說已有充分的理解,
有時是知其然而不知其所以然,寧可先不寫,以免有誤導板友之嫌,請見諒...

1. '此程式碼修改自麻辣家族討論區excel高手淮提部林前輩所寫,非我自創.
   
2. '討論區網址:http://forum.twbts.com/index.php
   
3. 
   
4. Sub test()
   
5. Dim arr, brr, myD, N, T
   
6. Set myD = CreateObject("scripting.dictionary")
   
7. arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8. ReDim brr(1 To UBound(arr), 1 To 4)
   
9. N = 1
   
10. For i = 1 To UBound(arr)
    
11. T = arr(i, 2) & arr(i, 3) & arr(i, 4)
    
12. If myD(T) = 1 Then GoTo 101
    
13. For j = 1 To 4
    
14. brr(N, j) = arr(i, j)
    
15. Next j
    
16. N = N + 1
    
17. myD(T) = 1
    
18. 101:
    
19. Next i
    
20. If N > 0 Then [h2].Resize(N, 4) = brr
    
21. End Sub

複製代碼

[attach]25654[/attach]

---

作者: GBKEE    時間: 2016-10-27 06:27

回復 11# greetingsfromtw
VBA 有許多寫法可達到相同的效果

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), i As Integer
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     AR = Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
6.     For i = 1 To UBound(AR)
   
7.       If Not D.exists(AR(i, 2) & AR(i, 3) & AR(i, 4)) Then  '** exists  傳回字典物件是否有這key值  有 True :無 False
   
8.         D(AR(i, 2) & AR(i, 3) & AR(i, 4)) = Application.Index(AR, i)  '** 工作表函數 Index
   
9.       End If
   
10.     Next
    
11.     With Range("H1")
    
12.         .CurrentRegion.Clear
    
13.         .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
    
14.     End With
    
15. End Sub
    
16. Sub Ex1()
    
17.     Dim D As Object, i As Integer
    
18.     Set D = CreateObject("scripting.dictionary")
    
19.     With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
    
20.         For i = 1 To .Rows.Count
    
21.             If Not D.exists(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) Then '** exists  傳回字典物件是否有這key值  有 True :無 False
    
22.                 D(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) = .Rows(i)
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     With Range("H1")
    
27.         .CurrentRegion.Clear
    
28.          .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
    
29.     End With
    
30. End Sub
    
31. Sub Ex2()
    
32.     Dim AR, ArSt(), i As Integer, St As String
    
33.     With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
    
34.         For i = 1 To .Rows.Count
    
35.                 St = .Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)
    
36.                 If IsEmpty(AR) Then
    
37.                     ReDim AR(1 To 1):     AR(1) = .Rows(i)
    
38.                     ReDim ArSt(1 To 1):   ArSt(1) = St
    
39.                 Else
    
40.                     If UBound(Filter(ArSt, St)) = -1 Then
    
41.                         'Filter 函數傳回一個從零開始的陣列，該陣列包含基於指定篩選準則的一個字串陣列的子集。
    
42.                         '語法  Filter(sourcesrray, match[, include[, compare]])
    
43.                         '如果在 sourcearray 中沒有發現與 match 相符合的值，Filter 傳回一個無陣列。如果 sourcearray 是 Null 或不是一個一維陣列，則產生錯誤。
    
44.                         'Filter 函數所傳回的陣列，其組成項目數剛好是所找到的符合項目數。
    
45.                         ReDim Preserve ArSt(1 To UBound(ArSt) + 1)
    
46.                         ArSt(UBound(ArSt)) = St
    
47.                         ReDim Preserve AR(1 To UBound(AR) + 1)
    
48.                         AR(UBound(AR)) = .Rows(i)
    
49.                     End If
    
50.             End If
    
51.         Next
    
52.     End With
    
53.     With Range("H1")
    
54.         .CurrentRegion.Clear
    
55.          .Resize(UBound(AR), 4) = Application.Transpose(Application.Transpose(AR))
    
56.     End With
    
57. End Sub

複製代碼

---

作者: 准提部林    時間: 2016-10-27 09:44

Application.Transpose 在不同版本的office各有其最大限制列數,
雖然大家幾乎都用了新版本, 但還是要提醒一下其他仍使用較舊版本的使用者!

---

作者: greetingsfromtw    時間: 2016-10-27 14:23

回復 12# GBKEE
回復 13# 准提部林

非常感謝GBKEE前輩提供另一種方式提供論壇板友學習,非常值得研究,小弟抱持感恩的心收下了.
也非常感謝淮提部林前輩提醒論壇板友關於Application.Transpose的限制,以後小弟練習時也會特別注意這個部份.

---

作者: linsurvey2005    時間: 2016-10-28 08:55

回復 12# GBKEE


   GBKEE前輩
附件是所需要的內容與呈現的成果
太晚回覆表示抱歉

另感謝多位前輩的指教我正在努力消化中

---

作者: linsurvey2005    時間: 2016-10-28 09:07

回復 10# 准提部林


    准提部林 前輩
問題解決了
我的疏失造成別人的困擾,下回有問題一定上傳附檔

也謝謝多位前輩的指教

---

作者: Andy2483    時間: 2023-5-10 11:43

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

執行前:
[attach]36330[/attach]

執行結果:
[attach]36331[/attach]


Option Explicit
Sub TEST_1()
Dim Brr, Y, i&, j&, N&, T$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([D1], Cells(Rows.Count, "A").End(xlUp))
'↑令Brr變數是 二維陣列,以儲存格值帶入陣列裡
For i = 2 To UBound(Brr)
'↑設順迴圈
   For j = 2 To 4: T = T & Brr(i, j) & "|": Next
   '↑設內順迴圈!收集字串以"|"符號間隔
   If Y(T) = "" Then
   '↑如果以T變數查Y字典得item是 空字元?
      N = N + 1: Y(T) = "@": T = ""
      '↑令N變數累加1(指定結果資料列號),
      '令T變數當key,item是 "@",納入Y字典(這是要註記item不是 "")
      '令T變數是 空字元(因為下個迴圈執行前要清空此變數)
      For j = 1 To 4: Brr(N + 1, j) = Brr(i, j): Next
      '↑設內順迴圈!將符合條件的資料逐次帶入結果列
   End If
Next
[H:K].ClearContents
'↑令清除舊結果資料
[H1].Resize(N + 1, 4) = Brr
'↑令Brr陣列資料從[H1]儲存格開始寫入值
'(N+1:是因為第一列是標題列,而N的累計不包含標題列)
Set Y = Nothing: Erase Brr
'↑令釋放變數
End Sub

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)