返回列表 上一主題 發帖

[發問] 這種重複值刪除的VBA該如何寫(2003)

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
1# 跳轉到 »
發表於 2016-10-7 12:15 | 顯示全部帖子
不好意思借標題問一下,

有試著將lpk187大的程式碼略做修改,

因為對VBA真的還是新手程度,所以修改的部份做得很不好,

先簡述目前希望達到的效果:
1.若兩橫列的J欄數值不同,L欄數值相同,
則僅清除其中一橫列的L欄數值,兩橫列均不刪除.

2.跟上述規則類似,
若兩橫列的J欄數值相同,L欄數值不同,
則僅清除其中一橫列的J欄數值,兩橫列均不刪除.

3.若兩橫列的J欄數值及L欄數值均為空白,
則兩橫列均刪除.
修改後程式碼如下:
  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
複製代碼
目前的問題在於,

測試少量資料時(比如說10筆以內),

看似沒有問題,

但是若測試大量資料時,

用EXCEL2007的內建的格式化條件設定,

去標出重複的值時,

會發現還是有很多重複資料沒被刪除,

需再跑第二次程式碼,

才會清除,

不知問題出在哪裡,

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

TOP

        靜思自在 : 是非當教育，讚美作警惕。
返回列表 上一主題