返回列表 上一主題 發帖

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

回復 1# terrykyo520
  1. Sub ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. For Each A In Range([B1], [B1].End(xlDown))
  5. If d.exists(A & A.Offset(, 1)) = False Then d(A & A.Offset(, 1)) = A.Offset(, -1).Resize(, 3).Value
  6. Next
  7. [A:C].ClearContents
  8. [A1].Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
  9. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 5# terrykyo520
試試!
  1. Public Sub ex()
  2. Dim ar()
  3. arr = Range("a2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
  4. k = UBound(arr)
  5. For i = 1 To UBound(arr) - 1
  6.     For j = i + 1 To UBound(arr)
  7.         If arr(i, 1) = "" Or arr(j, 1) = "" Then GoTo 10
  8.         If arr(i, 2) & arr(i, 3) = arr(j, 2) & arr(j, 3) Then
  9.             arr(j, 1) = ""
  10.             arr(j, 2) = ""
  11.             arr(j, 3) = ""
  12.             k = k - 1
  13.         End If
  14. 10:
  15.     Next
  16. Next

  17. ReDim ar(1 To k, 1 To 3)
  18. k = 1
  19. For i = 1 To UBound(arr)
  20.     If arr(i, 1) <> "" Then
  21.         ar(k, 1) = arr(i, 1)
  22.         ar(k, 2) = arr(i, 2)
  23.         ar(k, 3) = arr(i, 3)
  24.         k = k + 1
  25.     End If
  26. Next
  27. Range("a2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
  28. [a2].Resize(UBound(ar), 3) = ar
  29. End Sub
複製代碼

TOP

回復 5# terrykyo520


    請列一期望的結果表是什麼
這樣比較好處理

TOP

本帖最後由 terrykyo520 於 2015-8-11 11:49 編輯

回復 4# Scott090
我套用下去結果怪怪的~會空一行又 再下一行A列的值跑到B去 B列的值跑到C列 C列的值不見
可否請幫我依這TEST的EXCEL下去看看呢~~謝謝教學~
想要執行後的結果如圖~左執行前~右為執行後

TEST.rar (1.59 KB)

TOP

回復 3# terrykyo520


   這個應沒有版本的區別
  1. Sub Test1()
  2.     Dim i&, j&
  3.     Dim aa, bb
  4.    
  5.     i = [A1].End(xlDown).Row
  6.     aa = Range("A2:C" & i).Value
  7.     For i = 1 To UBound(aa) - 1
  8.         For j = i + 1 To UBound(aa)
  9.             If aa(j, 2) = aa(i, 2) And aa(j, 3) = aa(i, 3) Then
  10.                 aa(j, 1) = "": aa(j, 2) = "": aa(j, 3) = ""
  11.             End If
  12.         Next
  13.     Next
  14.     ReDim bb(UBound(aa), 3)
  15.     j = 0
  16.     For i = 1 To UBound(aa)
  17.         If aa(i, 1) <> "" Then
  18.             j = j + 1
  19.             bb(j, 1) = aa(i, 1): bb(j, 2) = aa(i, 2): bb(j, 3) = aa(i, 3)
  20.         End If
  21.     Next
  22.     Range("A2").Resize(UBound(aa), 3).Clear
  23.     Range("A2").Resize(UBound(bb), 3) = bb

  24. End Sub
複製代碼

TOP

回復 2# Scott090


RemoveDuplicates這只有2007以上版本才可用
我的版本是2003的
謝謝

TOP

回復 1# terrykyo520


    試試看這個是否符合需要
  1. Sub Test0()
  2.     Dim H&
  3.     Range("A2").Select
  4.     H = [A1].End(xlDown).Row
  5.     Range("$A$1:$C$" & H).RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
  6. End Sub
複製代碼

TOP

        靜思自在 : 人生沒有所有權,只有生命的使用權。
返回列表 上一主題