12
返回列表 上一主題 發帖

[發問] 清除重覆資料,只存留1筆資料

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-10-24 12:34 | 只看該作者

[發問] 清除重覆資料,只存留1筆資料

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

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

收藏 分享
開心學習,學習很開心

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1447 
主題
40 
精華
0 
積分
1471 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-12-5 
17#
發表於 2023-5-10 11:43 | 只看該作者
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:


執行結果:



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
16#
發表於 2016-10-28 09:07 | 只看該作者
回復 10# 准提部林


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

也謝謝多位前輩的指教
開心學習,學習很開心

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
15#
發表於 2016-10-28 08:55 | 只看該作者
回復 12# GBKEE


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

另感謝多位前輩的指教我正在努力消化中
開心學習,學習很開心

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
14#
發表於 2016-10-27 14:23 | 只看該作者
回復 12# GBKEE
回復 13# 准提部林

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

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-12-27 
13#
發表於 2016-10-27 09:44 | 只看該作者
Application.Transpose 在不同版本的office各有其最大限制列數,
雖然大家幾乎都用了新版本, 但還是要提醒一下其他仍使用較舊版本的使用者!

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
11#
發表於 2016-10-26 23:20 | 只看該作者
回復 10# 准提部林

同意淮提部林前輩所言,

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

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

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

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

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

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

vba功力太差,改得不好,希望有所幫助,有不當處也請前輩們務必指點一二,感謝.
本想寫註解,但因目前對前輩所寫的原本程式碼還不敢說已有充分的理解,
有時是知其然而不知其所以然,寧可先不寫,以免有誤導板友之嫌,請見諒...
  1. '此程式碼修改自麻辣家族討論區excel高手淮提部林前輩所寫,非我自創.
  2. '討論區網址:http://forum.twbts.com/index.php

  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
複製代碼
2-2 (多欄資料)多欄資料皆相同才刪除重複橫列.zip (9.44 KB)

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-12-27 
10#
發表於 2016-10-26 11:51 | 只看該作者
編號78與5只有C.D欄相同, 為何只保留5???
VBA問題最好上傳附檔!!

TOP

hcm19522

帖子
1392 
主題
4 
精華
0 
積分
1402 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-12-28 

熱烈參與勳章
9#
發表於 2016-10-25 10:23 | 只看該作者
http://blog.xuite.net/hcm19522/twblog/225435151
參考~
http://blog.xuite.net/hcm19522/twblog/458258396

TOP

        靜思自在 : 【時間如鑽石】時間對一個有智慧的人而言，就如鑽石般珍貴；但對愚人來說，卻像是一把泥土，一點價值也沒有。
12
返回列表 上一主題