Board logo

標題: [發問] 判別重複後，依照條件刪除 [打印本頁]
作者: Michelle-W    時間: 2016-7-20 16:27     標題: 判別重複後，依照條件刪除

請問要達成以下的目的的話，目前的程式碼應該如何做修改?
或是有其他較好的寫法? (資料筆數不止附件這些，只是簡化成比較容易解釋^^")
1. 先比對A欄是否有重複
2. 發現重複後，比對後面(C:G)是否有非空格
3.1 若兩者皆空格，刪除其一
3.2 若其中有一個後面有文字，則刪除另一個後面為空格的那個



感謝~~

[attach]24706[/attach]
作者: vinejason    時間: 2016-7-20 17:02

回復 1# Michelle-W

我通常先用以下函數找出重複資料 , 然後再篩選"重複" 刪除
提供給你參考
=IF(COUNTIF($A$2:$A$6,A2)=1,"","重複")
作者: c_c_lai    時間: 2016-7-20 20:25

回復 1# Michelle-W
  1. Sub Ex()
  2.     Dim rng As Range, dic As Object
  3.     Dim r As Long
  4.    
  5.     r = [A2].End(xlDown).Row
  6.     Range("$A$2:$G$" & r).RemoveDuplicates Columns:=Array(2, 4), Header:=xlYes
  7.    
  8.     Set dic = CreateObject("scripting.dictionary")
  9.     For Each rng In Range("A2", [A2].End(xlDown))
  10.         If Not dic.exists(CStr(rng.Offset(, 1).Value)) Then dic(CStr(rng.Offset(, 1).Value)) = ""
  11.         If rng.Offset(, 3) <> "" Then dic(CStr(rng.Offset(, 1).Value)) = rng.Offset(, 3)
  12.     Next
  13.    
  14.     For r = Range("A2").End(xlDown).Row To 2 Step -1
  15.         If Cells(r, 4) <> dic(CStr(Cells(r, 2).Value)) Then Rows(r).EntireRow.Delete
  16.     Next
  17. End Sub
複製代碼
[attach]24710[/attach]
  [attach]24711[/attach]
作者: Michelle-W    時間: 2016-7-22 13:57

回復 2# vinejason


謝謝您的指點 :D
作者: Michelle-W    時間: 2016-7-22 14:21

回復 3# c_c_lai


您好
昨日私下請教您關於這段程式碼的含意，但研究了一天還是有些地方不懂QQ
因為我星期一到五都會可能會有資料要判讀(資料筆數不少)，不是只侷限在星期二而已
我想說研究您提供的程式碼做修改
但還是改不出來QQ"
能在請您幫忙看看嗎?
(不懂哪部分的程式碼是重複後判別"留下後面有文字的,刪除另一個重複-後面為空白的")
再次感謝


[attach]24724[/attach]
作者: c_c_lai    時間: 2016-7-22 17:06

回復 5# Michelle-W
  1. Sub Ex()
  2.     Dim rng As Range, dic As Object
  3.     Dim r As Long, txt As String
  4.    
  5.     r = [A2].End(xlDown).Row
  6.     Range("$A$1:$G$" & r).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
  7.    
  8.     Set dic = CreateObject("scripting.dictionary")
  9.     For Each rng In Range("A2", [A2].End(xlDown))
  10.          If Not dic.exists(CStr(rng.Value)) Then dic(CStr(rng.Value)) = ""
  11.         If rng.Offset(, 2) <> "" Or rng.Offset(, 3) <> "" Or rng.Offset(, 4) <> "" Or rng.Offset(, 5) <> "" Or rng.Offset(, 6) <> "" Then
  12.             txt = Left(rng.Offset(, 2) & "          ", 10) & Left(rng.Offset(, 3) & "          ", 10) & _
  13.                   Left(rng.Offset(, 4) & "          ", 10) & Left(rng.Offset(, 5) & "          ", 10) & Left(rng.Offset(, 6) & "          ", 10)
  14.         Else
  15.             txt = ""
  16.         End If
  17.         
  18.         If txt <> "" Then dic(CStr(rng.Value)) = txt
  19.      Next
  20.    
  21.     For r = Range("A2").End(xlDown).Row To 2 Step -1
  22.         If Cells(r, 3) <> "" Or Cells(r, 4) <> "" Or Cells(r, 5) <> "" Or Cells(r, 6) <> "" Or Cells(r, 7) <> "" Then
  23.             txt = Left(Cells(r, 3) & "          ", 10) & Left(Cells(r, 4) & "          ", 10) & _
  24.               Left(Cells(r, 5) & "          ", 10) & Left(Cells(r, 6) & "          ", 10) & Left(Cells(r, 7) & "          ", 10)
  25.         Else
  26.             txt = ""
  27.         End If
  28.          If txt <> dic(CStr(Cells(r, 1).Value)) Then Rows(r).EntireRow.Delete
  29.     Next
  30. End Sub
複製代碼
[attach]24725[/attach]
作者: 准提部林    時間: 2016-7-22 17:45

Sub TEST()
Dim xR As Range, xDic, xU As Range, N&, V&, XX As Range
Set xDic = CreateObject("Scripting.Dictionary")
For Each xR In Range([A2], [A65536].End(xlUp))
　　N = xDic(xR.Value)
　　If N = 0 Then xDic(xR.Value) = xR.Row: GoTo 101
　　V = Application.CountA(Range(xR(1, 3), xR(1, 7)))
　　Set XX = xR
　　If V > 0 Then Set XX = Range("A" & N): xDic(xR.Value) = xR.Row
　　If xU Is Nothing Then Set xU = XX Else Set xU = Union(xU, XX)
101: Next
If Not xU Is Nothing Then xU.EntireRow.Delete
End Sub

表格底下的說明先刪除再執行，
程式碼不太好解釋，先用看看！
作者: Michelle-W    時間: 2016-7-23 10:34

回復 7# 准提部林


謝謝您的幫忙，可以用~
但我有點好奇您程式碼的意思
如果可以的話，可以麻煩您大概講解一下嗎?^^"
感謝
作者: 准提部林    時間: 2016-7-23 11:25

回復 9# Michelle-W

＜拜金女的好友名單＞
以下只解釋邏輯，不解釋語法，為了易於了解，部份有修改，
〔xDic字典檔〕及〔Union聯集儲存格〕的用法，自行去查說明：
　
Sub TEST()
Dim xR As Range, xDic, xU As Range, N&, V&, XX As Range
Set xDic = CreateObject("Scripting.Dictionary")
For Each xR In Range([A2], [A65536].End(xlUp))
　
　　N = xDic(xR.Value)
　　If N = 0 Then xDic(xR.Value) = xR.Row: GoTo 101
　　'＿第一次遇見你，請留下您的電話號碼(列號)：xDic(xR.Value) = xR.Row
　　'＿N = 0，表示第一次的相遇，記住列號後，略過下方的語句(GoTo 101)
　
　　V = Application.CountA(Range(xR(1, 3), xR(1, 7)))　
　　'＿第二次（及以後）遇見你，請問你口袋有沒有錢（檢查非空格）
　
　　If V = 0 Then Set XX = xR
　　'＿如果沒有錢，你這次的新電話號碼我不想留：Set XX = xR
　
　　If V > 0 Then Set XX = Range("A" & N): xDic(xR.Value) = xR.Row
　　'＿如果有錢，上次留的電話作廢：Set XX = Range("A" & N)
　　'＿換留這次的新電話號碼：xDic(xR.Value) = xR.Row
　
　　If xU Is Nothing Then Set xU = XX Else Set xU = Union(xU, XX)
　　'＿將要作廢的電話號碼集中起來
　
101: Next
　
If Not xU Is Nothing Then xU.EntireRow.Delete
'＿一次刪去作廢電話號碼
End Sub
作者: c_c_lai    時間: 2016-7-24 17:43

回復 7# 准提部林
准大在此範例中，應用泡沫排序 (Bubble Sort) 的處理，
真是恰當好處，表現的淋漓盡致，在此受教了，謝謝您！
作者: Michelle-W    時間: 2016-7-25 09:14

回復 9# 准提部林


謝謝准提部林的教學~
這樣好容易懂哦!!
非常感謝^^
作者: hcm19522    時間: 2016-7-26 17:45

http://blog.xuite.net/hcm19522/twblog/435662193



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