Board logo

標題: 比對兩直欄的數值刪除重複橫列問題 [打印本頁]
作者: greetingsfromtw    時間: 2016-10-16 22:58     標題: 比對兩直欄的數值刪除重複橫列問題

(檔案連結:)

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

本想試著使用字典物件,

但因所想比對的兩欄數值(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")

  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

  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

  31.         ElseIf arr(i, 11) = "" And arr(i, 13) = "" Then
  32.         arr(i, 1) = ""

  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

  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

  56. Columns(1).ClearContents
  57. [L2].Select
  58. End Sub
複製代碼
可以的話,
希望能夠有前輩不吝指點小弟,十分感謝.
作者: GBKEE    時間: 2016-10-17 09:18

回復 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    時間: 2016-10-17 13:23

本帖最後由 greetingsfromtw 於 2016-10-17 13:25 編輯

回復 2# GBKEE

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

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


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


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

====

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

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

若遇上面所述兩點情形,


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


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


小弟斗膽,

不知是否能夠麻煩前輩不吝指點迷津,十分感謝.
作者: greetingsfromtw    時間: 2016-10-17 14:41

回復 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    時間: 2016-10-18 05:57

回復 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
複製代碼
作者: 准提部林    時間: 2016-10-18 10:28

本帖最後由 准提部林 於 2016-10-18 10:32 編輯

2000無法正常開啟附檔（格式太多），
只能猜，無法試解！
作者: greetingsfromtw    時間: 2016-10-18 12:26

回復 5# GBKEE


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

真的沒想到字典物件還有如此高深的運用方式,
小弟對VBA的了解實在是太少了,一定努力學習.感謝前輩無私指點.
作者: greetingsfromtw    時間: 2016-10-18 12:35

回復 6# 准提部林

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

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

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

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

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

[attach]25570[/attach]
作者: 准提部林    時間: 2016-10-18 13:26

回復 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    時間: 2016-10-18 15:40

回復 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為識別碼


  19. 101: Next i
  20. If N = 0 Then Exit Sub
  21. [c2:AD2].Resize(UBound(Arr)).Clear '清空原資料

  23. [c2:AD2].Resize(N) = Arr '填入更新資料
  24. End Sub
複製代碼




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