比對兩直欄的數值刪除重複橫列問題

greetingsfromtw

(檔案連結:)

各位前輩好,
小弟遇到一個問題,

本想試著使用字典物件,

但因所想比對的兩欄數值(K欄與M欄)欄位有可能會其中一欄空白,
另一欄非空白,
在這樣的情形下若是因空白而刪除,
恐怕會刪到不該刪的資料,

之前有比照板上前輩提供的程式碼去修改後做出一個檔案,
應該是板上沒錯,但不知該如何用搜索功能查詢自己的回文(非帖子),
以後使用前輩程式碼實在應該加註解附上原出處才是,
請見諒,小弟以後一定注意.

目前這個檔案還是有些問題,

有時明明兩欄皆為空白,但該橫列仍未被刪除;
第二點就是C欄必須非空白,
但不知該如何做修改.

還有一點就是不知何故,
明明重複的資料,還是無法徹底刪除,
這點也令小弟相當不解,
少量資料測試時沒有太大問題,

但大量資料就會出現問題.



先將小弟所期望的程式碼規則詳述如下以供參考:

(第一橫列為欄位名稱,不做比對.
資料共計15欄位,K欄與M欄為想要比對的數值,
兩欄數值無關連,不互相比對,僅自行比對)

1.若兩個或多個橫列的欄位K數值相同(或空白),且欄位M數值也相同(或空白),
則只留下一橫列,其餘刪除.

2.若兩個或多個橫列的欄位K數值相同,但欄位M的數值不同,
則這些橫列不變動.
在這些橫列中,留下一欄位的K數值,其餘橫列的欄位M清除.
欄位M的數值與位置不變動.

3.與上述規則相似,
若兩個或多個橫列的欄位K數值不同,但欄位M數值相同,
則這些橫列不變動.
欄位K的數值與位置不變動.
留下一欄位M數值,其餘橫列的欄位L數值清除.

4.若橫列的欄位K跟欄位M均為空白,
則刪除此橫列.

5.欄位K的數值與欄位M的數值不互相比較,兩欄數值各自比對,沒有關聯.

6.欄位K及欄位M的數值均為正整數或空白,不會是0或其他值.


附上小弟參考前輩程式碼修改後的程式及附檔如下:

附檔下載(Google雲端硬碟)

1. Public Sub extwo()
   
2. Dim ar()
   
3. Range("c2").Resize(Cells(Rows.Count, 3).End(xlUp).Row, 1).Select
   
4. Selection.Resize(Selection.Rows.Count - 1, 1).Select
   
5. Selection.Copy Range("a2")
   
6. 
   
7. arr = Range("A2:AD" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8. K = UBound(arr)
   
9. For i = 1 To UBound(arr) - 1
   
10.     For j = i + 1 To UBound(arr)
    
11.         If arr(i, 1) = "" Or arr(j, 1) = "" Then GoTo 10
    
12.         If arr(i, 11) & arr(i, 13) = arr(j, 11) & arr(j, 13) Then
    
13.             For L = 1 To UBound(arr, 2)
    
14.                 arr(j, L) = ""
    
15.             Next
    
16.             K = K - 1
    
17.         ElseIf arr(i, 11) = arr(j, 11) And arr(i, 13) <> arr(j, 13) Then
    
18.             If arr(i, 13) = "" Then
    
19.             arr(i, 11) = ""
    
20.             Else
    
21.             arr(j, 11) = ""
    
22.             End If
    
23. 
    
24.         ElseIf arr(i, 11) <> arr(j, 11) And arr(i, 13) = arr(j, 13) Then
    
25.             If arr(i, 11) = "" Then
    
26.             arr(i, 13) = ""
    
27.             Else
    
28.             arr(j, 13) = ""
    
29.             End If
    
30. 
    
31.         ElseIf arr(i, 11) = "" And arr(i, 13) = "" Then
    
32.         arr(i, 1) = ""
    
33. 
    
34.         ElseIf arr(j, 11) = "" And arr(j, 13) = "" Then
    
35.         arr(j, 1) = ""
    
36. '
    
37.         End If
    
38.         
    
39. 10:
    
40.     Next
    
41. Next
    
42. 
    
43. ReDim ar(1 To K, 1 To UBound(arr, 2))
    
44. K = 1
    
45. For i = 1 To UBound(arr)
    
46.     If arr(i, 1) <> "" Then
    
47.         For L = 1 To UBound(arr, 2)
    
48.             ar(K, L) = arr(i, L)
    
49.         Next
    
50.         K = K + 1
    
51.     End If
    
52. Next
    
53. Range("a2:AD" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
    
54. [a2].Resize(UBound(ar), UBound(arr, 2)) = ar
    
55. 
    
56. Columns(1).ClearContents
    
57. [L2].Select
    
58. End Sub

複製代碼

可以的話,
希望能夠有前輩不吝指點小弟,十分感謝.

GBKEE

回復 1# greetingsfromtw
試試看 是這樣媽?

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, Rng As Range, i As Long, St As String
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
5.     Set Rng = Range("B:P").Rows
   
6.     For i = 2 To Rng.Rows.Count
   
7.         If Application.CountA(Rng(1).Rows(i)) = 0 Then Exit For
   
8.         With Rng.Rows(i)
   
9.             St = Trim(.Cells(10)) & Trim(.Cells(12))
   
10.            '**第二點就是C欄必須非空白
    
11.             If .Cells(2) <> "" And St <> "" Then
    
12.                 If D.EXISTS(St) = False Then D(St) = Rng.Rows(i).Value
    
13.                 '1.若兩個或多個橫列的欄位K數值相同(或空白),且欄位M數值也相同(或空白),
    
14.                 '2.若兩個或多個橫列的欄位K數值相同,但欄位M的數值不同,
    
15.             End If
    
16.         End With
    
17.     Next
    
18.     If D.Count > 0 Then
    
19.         Rng(1).Offset(, Rng.Columns.Count + 2).Resize(D.Count, Rng.Columns.Count).Value _
    
20.                      = Application.Transpose(Application.Transpose(D.ITEMS))
    
21.     End If
    
22. End Sub

複製代碼

greetingsfromtw

回復 2# GBKEE

非常感謝GBKEE前輩無私提供程式碼,

也讓小弟知道字典物件是可以這樣使用的,
小弟今天研究了好一陣子,從中獲益甚多,
照這樣看來,字典物件實在是太強大了,
可用於解決許多棘手問題.


另外值得一提的是,
前輩還費心在程式碼中提供相關註解以利小弟學習研究之用,
這點令人感動,再次感謝前輩.


可以的話請允許小弟斗膽進一步詢問相關問題,

====

1.若兩個或多個橫列的欄位K數值相同,但欄位M的數值不同,
則這些橫列不變動.
在這些橫列中,留下一欄位的K數值,其餘橫列的欄位M清除.
欄位M的數值與位置不變動.
橫列均不刪除.
2.與上述規則相似,
若兩個或多個橫列的欄位K數值不同,但欄位M數值相同,
則這些橫列不變動.
欄位K的數值與位置不變動.
留下一欄位M數值,其餘橫列的欄位K數值清除.
橫列均不刪除.
===

在使用前輩所提供的程式碼時,

若遇上面所述兩點情形,


則會出現問題,這些橫列相同的數值不會被刪除.


也是小弟表達能力不太好,請見諒,有些地方也寫錯,
已略作修改,
以後一定會將問題做更清楚的呈現並檢查過後再提交,造成困擾不好意思.


小弟斗膽,

不知是否能夠麻煩前輩不吝指點迷津,十分感謝.

greetingsfromtw

回復 2# GBKEE

感謝前輩提醒,以後發文詢問會直接附上壓縮檔較為直接,文字說明有時不易說明清楚.
附上檔案,請前輩參考:


小弟將檔案說明貼至此以利對照用:

說明:
原始資料橫列2至橫列4的數值2相同,但數值1不同,故數值1不動,數值2保留一個,其餘刪除.
原始資料橫列5至橫列7的數值1相同,但數值2不同,故數值2不動,數值1保留一個,其餘刪除.
原始資料橫列8至10的數值2均相同,數值1空白,故只保留一橫列,其餘兩橫列刪除.保留哪一橫列均可.
原始資料橫列11至13的數值1均相同,數值2空白,故只保留一橫列,其餘兩橫列刪除.保留哪一橫列均可.
原始資料橫列14的數值1及數值2均為空白,故直接刪除此橫列.

還望前輩不吝指點迷津,十分感謝.

GBKEE

回復 4# greetingsfromtw
這樣對嗎?

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D(1 To 3) As Object, Rng As Range, i As Long, S1 As String, S2 As String, AR
   
4.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
   
5.     Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
   
6.     Set D(3) = CreateObject("SCRIPTING.DICTIONARY")
   
7.     Set Rng = Range("B:P").Rows
   
8.     For i = 2 To Rng.Rows.Count
   
9.         If Application.CountA(Rng(1).Rows(i)) = 0 Then Exit For
   
10.         With Rng.Rows(i)
    
11.             If .Cells(2) <> "" Then '**第二點就是C欄必須非空白
    
12.                 S1 = .Cells(10)
    
13.                 S2 = .Cells(12)
    
14.                 If Not D(1).EXISTS(S1) And Not D(2).EXISTS(S2) Then
    
15.                     '**字典物件1的Key沒有 數值1  且  字典物件2的Key沒有 數值2
    
16.                         If S1 <> "" And S2 <> "" Then D(3)(S1 & S2) = Rng.Rows(i).Value
    
17.                         D(1)(S1) = ""
    
18.                         D(2)(S2) = ""
    
19.                 ElseIf Not D(1).EXISTS(S1) And D(2).EXISTS(S2) Then
    
20.                       '**字典物件1的Key沒有 數值1  且  字典物件2的Key 有 數值2
    
21.                      AR = Rng.Rows(i).Value
    
22.                      AR(1, 12) = ""                        '**  不要數值2
    
23.                      D(3)(S1) = AR
    
24.                 ElseIf D(1).EXISTS(S1) And Not D(2).EXISTS(S2) Then
    
25.                     '**字典物件1的Key 有 數值1  且  字典物件2的Key 沒有 數值2
    
26.                      AR = Rng.Rows(i).Value
    
27.                      AR(1, 10) = ""                       '**  不要數值1
    
28.                      D(3)(S2) = AR
    
29.                 End If
    
30.             End If
    
31.         End With
    
32.     Next
    
33.     If D(3).Count > 0 Then
    
34.         Rng(1).Offset(2, Rng.Columns.Count + 2).Resize(D(3).Count, Rng.Columns.Count).Value _
    
35.                      = Application.Transpose(Application.Transpose(D(3).ITEMS))
    
36.     End If
    
37. End Sub

複製代碼

准提部林

2000無法正常開啟附檔（格式太多），
只能猜，無法試解！

greetingsfromtw

回復 5# GBKEE


非常感謝GBKEE前輩耐心提供解答,
確實可以完美運作,沒有問題.

真的沒想到字典物件還有如此高深的運用方式,
小弟對VBA的了解實在是太少了,一定努力學習.感謝前輩無私指點.

greetingsfromtw

回復 6# 准提部林

實在抱歉,小弟當初只顧著傳檔,沒考慮到相容性問題,
以後小弟發問時的附檔會記得改成.xls格式,造成困擾不好意思.

已在此篇附上.xls格式,請前輩參考.

之前也蒙淮提部林前輩指點高深技巧,小弟從中獲益不少,覺得這個討論區不僅高手如雲,而且都願意無私指點像小弟這樣的VBA新手,實在非常感謝.

GBKEE前輩已有提供問題解答,但同一個問題的解答肯定不只一種,若淮提部林前輩願意抽空指點小弟其他解答方式就太好,

再次感謝前輩們的無私指點,
小弟一定努力學習.

20161018修改(.xls格式)-問題-自動刪除重複數值及空白橫列.zip (164.67 KB)

下載次數: 4

2016-10-18 12:27

准提部林

回復 8# greetingsfromtw

還是無法正常開啟檔案(格式太多), 大概猜著寫, 能自行更改最好:

1. Sub T_TEST()
   
2. Dim Arr, i&, j%, xD, TK&, TM&, N&
   
3. Arr = Range("A2:AD" & Cells(Rows.Count, 1).End(xlUp).Row)
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. For i = 1 To UBound(Arr)
   
6.     If Arr(i, 3) = "" Then GoTo 101 'C欄不為空
   
7.     TK = "k" & Arr(i, 11):  TM = "m" & Arr(i, 13) '數字各自冠上不同文字區別
   
8.     If xD(TK & TM) = 1 Then GoTo 101 '兩欄完全相同且已納入字典, 不處理
   
9.     If xD(TK) = 1 Then Arr(i, 11) = "": GoTo 999 'K值相同且非第一筆, 清空K值
   
10.     If xD(TM) = 1 Then Arr(i, 13) = "": GoTo 999 'M值相同且非第一筆, 清空M值
    
11. 999: N = N + 1
    
12.     For j = 1 To UBound(Arr, 2): Arr(N, j) = Arr(i, j): Next '取得更新後的資料放在原陣列
    
13.     xD(TK & TM) = 1: xD(TK) = 1: xD(TM) = 1 '納入字典檔並冠上1為識別碼
    
14. 101: Next i
    
15. If N = 0 Then Exit Sub
    
16. [A2:AD2].Resize(UBound(Arr)).Clear '清空原資料
    
17. [A2:AD2].Resize(N) = Arr '填入更新資料
    
18. End Sub

複製代碼

greetingsfromtw

回復 9# 准提部林
非常感謝淮提部林前輩無私提供程式碼,小弟大開眼界.
兩位前輩所使用的解題方式都是小弟前所未見,需要一點時間消化.
真的非常感謝.

後來發現該檔案不知何故被告知有一格式存在,怎麼清也清不掉,
另開新檔再把資料重新輸入後即解決問題,
造成前輩困擾,真的很不好意思,下次附檔時一定注意.


小弟冒昧將前輩程式碼略做修改後,確實已解決問題,附上修改後程式碼如下,
再次感謝前輩熱心協助.
字典物件真的是一門高深學問,一定努力學習.

1. 'http://forum.twbts.com/viewthread.php?from=notice&tid=18582
   
2. '感謝淮提部林前輩提供原始程式碼
   
3. '此版本是從前輩所提供之原始程式碼去進行修改
   
4. Sub T_TEST()
   
5. Dim Arr, i&, j%, xD, TK, TM, N&
   
6. Arr = Range("c2:AD" & Cells(Rows.Count, 3).End(xlUp).Row)
   
7. Set xD = CreateObject("Scripting.Dictionary")
   
8. For i = 1 To UBound(Arr)
   
9.     If Arr(i, 1) = "" Then GoTo 101 'C欄不為空
   
10.     TK = "k" & Arr(i, 9):  TM = "m" & Arr(i, 11) '數字各自冠上不同文字區別
    
11.     If xD(TK & TM) = 1 Then GoTo 101 '兩欄完全相同且已納入字典, 不處理
    
12.     If xD(TK) = 1 Then Arr(i, 9) = "": GoTo 999 'K值相同且非第一筆, 清空K值
    
13.     If xD(TM) = 1 Then Arr(i, 11) = "": GoTo 999 'M值相同且非第一筆, 清空M值
    
14. 999: N = N + 1
    
15.     For j = 1 To UBound(Arr, 2): Arr(N, j) = Arr(i, j): Next '取得更新後的資料放在原陣列
    
16.     xD(TK & TM) = 1: xD(TK) = 1: xD(TM) = 1 '納入字典檔並冠上1為識別碼
    
17. 
    
18. 
    
19. 101: Next i
    
20. If N = 0 Then Exit Sub
    
21. [c2:AD2].Resize(UBound(Arr)).Clear '清空原資料
    
22. 
    
23. [c2:AD2].Resize(N) = Arr '填入更新資料
    
24. End Sub

複製代碼