返回列表 上一主題 發帖

[發問] 判別重複後，依照條件刪除

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-3 
1# 跳轉到 »
發表於 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

表格底下的說明先刪除再執行，
程式碼不太好解釋，先用看看！

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-3 
2#
發表於 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

TOP

        靜思自在 : 虛空有盡．我願無窮，發願容易行願難。
返回列表 上一主題