清除重覆資料,只存留1筆資料(頁 1) - Excel程式區

linsurvey2005 發表於 2016-10-24 12:34

清除重覆資料,只存留1筆資料

[i=s] 本帖最後由 linsurvey2005 於 2016-10-24 12:43 編輯 [/i]

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

[attach]25621[/attach]

starbox520 發表於 2016-10-24 13:19

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94986&ptid=18628]1#[/url] [i]linsurvey2005[/i] [/b]

EXCEL->資料 ->移除重複

linsurvey2005 發表於 2016-10-24 13:48

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94987&ptid=18628]2#[/url] [i]starbox520[/i] [/b]

感謝回覆
因為資料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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94990&ptid=18628]4#[/url] [i]rouber590324[/i] [/b]

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

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

rouber590324 發表於 2016-10-24 16:55

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

GBKEE 發表於 2016-10-24 19:58

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94993&ptid=18628]6#[/url] [i]rouber590324[/i] [/b]

試試看[code]Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range
   Set Rng(1) = ActiveSheet.Range("a1").CurrentRegion  '資料所在的範圍
   Set Rng(2) = ActiveSheet.Cells(1, Columns.Count - Rng(1).Columns.Count)
   With Rng(1)
      .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("B1:D1"), Unique:=True
      'Rng(1)的進階篩選:,  範圍中的 B:D 欄,不重複的資料
      .Copy Rng(2)
      .AdvancedFilter xlFilterInPlace '全部資料顯示
      .Cells.Clear
   End With
   Rng(2).CurrentRegion.Copy Rng(1)(1)
   Rng(2).Clear
End Sub
[/code]

linsurvey2005 發表於 2016-10-24 22:49

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94997&ptid=18628]7#[/url] [i]GBKEE[/i] [/b]

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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95040&ptid=18628]10#[/url] [i]准提部林[/i] [/b]

同意淮提部林前輩所言,

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

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

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

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

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

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

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

Sub test()
Dim arr, brr, myD, N, T
Set myD = CreateObject("scripting.dictionary")
arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 4)
N = 1
For i = 1 To UBound(arr)
T = arr(i, 2) & arr(i, 3) & arr(i, 4)
If myD(T) = 1 Then GoTo 101
For j = 1 To 4
brr(N, j) = arr(i, j)
Next j
N = N + 1
myD(T) = 1
101:
Next i
If N > 0 Then [h2].Resize(N, 4) = brr
End Sub
[/code][attach]25654[/attach]

GBKEE 發表於 2016-10-27 06:27

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95056&ptid=18628]11#[/url] [i]greetingsfromtw[/i] [/b]
VBA 有許多寫法可達到相同的效果[code]Option Explicit
Sub Ex()
Dim D As Object, AR(), i As Integer
Set D = CreateObject("scripting.dictionary")
AR = Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(AR)
   If Not D.exists(AR(i, 2) & AR(i, 3) & AR(i, 4)) Then  '** exists  傳回字典物件是否有這key值  有 True :無 False
      D(AR(i, 2) & AR(i, 3) & AR(i, 4)) = Application.Index(AR, i)  '** 工作表函數 Index
   End If
Next
With Range("H1")
      .CurrentRegion.Clear
      .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
End With
End Sub
Sub Ex1()
Dim D As Object, i As Integer
Set D = CreateObject("scripting.dictionary")
With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
      For i = 1 To .Rows.Count
         If Not D.exists(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) Then '** exists  傳回字典物件是否有這key值  有 True :無 False
            D(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) = .Rows(i)
         End If
      Next
End With
With Range("H1")
      .CurrentRegion.Clear
      .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
End With
End Sub
Sub Ex2()
Dim AR, ArSt(), i As Integer, St As String
With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
      For i = 1 To .Rows.Count
            St = .Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)
            If IsEmpty(AR) Then
                  ReDim AR(1 To 1):    AR(1) = .Rows(i)
                  ReDim ArSt(1 To 1): ArSt(1) = St
            Else
                  If UBound(Filter(ArSt, St)) = -1 Then
                     'Filter 函數傳回一個從零開始的陣列，該陣列包含基於指定篩選準則的一個字串陣列的子集。
                     '語法  Filter(sourcesrray, match[, include[, compare]])
                     '如果在 sourcearray 中沒有發現與 match 相符合的值，Filter 傳回一個無陣列。如果 sourcearray 是 Null 或不是一個一維陣列，則產生錯誤。
                     'Filter 函數所傳回的陣列，其組成項目數剛好是所找到的符合項目數。
                     ReDim Preserve ArSt(1 To UBound(ArSt) + 1)
                     ArSt(UBound(ArSt)) = St
                     ReDim Preserve AR(1 To UBound(AR) + 1)
                     AR(UBound(AR)) = .Rows(i)
                  End If
         End If
      Next
End With
With Range("H1")
      .CurrentRegion.Clear
      .Resize(UBound(AR), 4) = Application.Transpose(Application.Transpose(AR))
End With
End Sub
[/code]

准提部林 發表於 2016-10-27 09:44

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

greetingsfromtw 發表於 2016-10-27 14:23

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95061&ptid=18628]12#[/url] [i]GBKEE[/i] [/b]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95080&ptid=18628]13#[/url] [i]准提部林[/i] [/b]

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

linsurvey2005 發表於 2016-10-28 08:55

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95061&ptid=18628]12#[/url] [i]GBKEE[/i] [/b]

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

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

linsurvey2005 發表於 2016-10-28 09:07

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95040&ptid=18628]10#[/url] [i]准提部林[/i] [/b]

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

也謝謝多位前輩的指教

Andy2483 發表於 2023-5-10 11:43

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

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

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

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

頁: [1]

麻辣家族討論版版's Archiver

清除重覆資料,只存留1筆資料