Board logo

標題: [發問] 這種重複值刪除的VBA該如何寫(2003) [打印本頁]
作者: terrykyo520    時間: 2015-8-10 16:23     標題: 這種重複值刪除的VBA該如何寫(2003)

EXCEL為2003版本
如果B列有重複就判斷C列是否也相同
不同則不刪除
B.C皆相同則刪除此行 舉例如下
    A     B    C
1  1   P1   B6
2  2   P1   B2
3  3   P1   B6
4  4   P2   B2
5  5   P5   B6

第2行的B為P1 與第1行的B值相同但C不同 不刪除
第3行的B與C和第1行的相同 故刪除
請問VBA該如何寫~謝謝
連刪除B欄重複值都寫不出來~...
例子圖
[attach]21680[/attach]
作者: Scott090    時間: 2015-8-10 20:31

回復 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
複製代碼
作者: terrykyo520    時間: 2015-8-10 21:03

回復 2# Scott090


RemoveDuplicates這只有2007以上版本才可用
我的版本是2003的
謝謝
作者: Scott090    時間: 2015-8-10 23:13

回復 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

  25. End Sub
複製代碼
作者: terrykyo520    時間: 2015-8-11 11:48

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

回復 4# Scott090
我套用下去結果怪怪的~會空一行又 再下一行A列的值跑到B去 B列的值跑到C列 C列的值不見
可否請幫我依這TEST的EXCEL下去看看呢~~謝謝教學~
想要執行後的結果如圖~左執行前~右為執行後
[attach]21684[/attach]
[attach]21685[/attach]
作者: Scott090    時間: 2015-8-11 15:27

回復 5# terrykyo520


    請列一期望的結果表是什麼
這樣比較好處理
作者: lpk187    時間: 2015-8-11 18:14

回復 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

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

回復 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
複製代碼
作者: Scott090    時間: 2015-8-11 18:49

回復 5# terrykyo520


    答案跟你的右圖一樣
[attach]21688[/attach]
作者: GBKEE    時間: 2015-8-13 16:46

還有方法可試
  1. Option Explicit
  2. Sub Ex()
  3.     Dim R As Range, Rng As Range
  4.     With ActiveSheet.UsedRange
  5.         .Columns("b:c").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  6.         For Each R In .Rows
  7.             If R.Height = 0 Then
  8.                 If Rng Is Nothing Then
  9.                     Set Rng = R
  10.                 Else
  11.                     Set Rng = Union(Rng, R)
  12.                 End If
  13.             End If
  14.         Next
  15.     End With
  16.     Application.DisplayAlerts = False
  17.     If Not Rng Is Nothing Then Rng.Delete
  18.     Application.DisplayAlerts = True
  19. End Sub
  20. Sub Ex1()
  21.     Dim Sh As Worksheet, wb As Workbook
  22.     Set Sh = ActiveSheet
  23.     Sh.Copy
  24.     Set wb = ActiveWorkbook
  25.     With wb.Sheets(1)
  26.         .UsedRange.Columns("b:c").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  27.         Sh.UsedRange.Clear
  28.         .UsedRange.Copy Sh.Range("A1")
  29.         .Parent.Close False
  30.     End With
  31. End Sub
複製代碼
作者: terrykyo520    時間: 2015-8-23 19:50

回復 8# lpk187
謝謝~可以耶~

請問這行的意思是
Cells(Rows.Count, 1).End(xlUp).Row

如果我的產品在第M列 地區在第Q列  資料總共到AD列
是要改成
arr = Range("a2:AD" & Cells(Rows.Count, 1).End(xlUp).Row)

要怎麼修改呢~謝謝
作者: terrykyo520    時間: 2015-8-23 19:58

回復 9# Hsieh

OK可行耶
我只看得懂 Dim A As Range
剩下~好難

如果我的產品在第M列 地區在第Q列  資料總共到AD列
要怎麼修改呢~謝謝
作者: terrykyo520    時間: 2015-8-23 19:59

回復 10# Scott090


    謝謝幫忙~目前我無法下載檔案
    只能先說聲3Q~之後再下載看看寫法~~
作者: lpk187    時間: 2015-8-23 20:43

回復 12# terrykyo520

Cells(Rows.Count, 1).End(xlUp).Row是A欄的最後一格的列號，Rows.Count為所有的列號，1就是A欄
原來的欄數只有些3欄，所以寫的比較簡單，但是若資料數量很多時就不能如下面表示的寫法，
            arr(j, 1) = ""
            arr(j, 2) = ""
            arr(j, 3) = ""
            ...
            ....
            .......
            .......
            arr(j, X) = ""
這樣寫會累死的
所以必須多一個迴圈
  1. Public Sub ex()
  2. Dim ar()
  3. arr = Range("A2:AD" & 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, 13) & arr(I, 17) = arr(j, 13) & arr(j, 17) Then
  9.             For L = 1 To UBound(arr, 2)
  10.                 arr(j, L) = ""
  11.             Next
  12.             K = K - 1
  13.         End If
  14. 10:
  15.     Next
  16. Next

  18. ReDim ar(1 To K, 1 To UBound(arr, 2))
  19. K = 1
  20. For I = 1 To UBound(arr)
  21.     If arr(I, 1) <> "" Then
  22.         For L = 1 To UBound(arr, 2)
  23.             ar(K, L) = arr(I, L)
  24.         Next
  25.         K = K + 1
  26.     End If
  27. Next
  28. Range("a2:AD" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
  29. [a2].Resize(UBound(ar), UBound(arr, 2)) = ar
  30. End Sub
複製代碼
作者: Scott090    時間: 2015-8-23 22:21

回復 14# terrykyo520

請注意陣列起始位置 是 0 還是 1
加 Option base 1 是定義陣列從 1 開始

參照 4#

Option base 1   
Sub Test1()
    Dim i&, j&
    Dim aa, bb
   
    i = [A1].End(xlDown).Row
    aa = Range("A2:C" & i).Value
   For i = 1 To UBound(aa) - 1
.........
作者: terrykyo520    時間: 2015-8-23 22:33

回復 11# GBKEE


這兩種也可以耶~好多方法
如果我的產品在第M列 地區在第Q列  資料總共到AD列
是要改成
Sub Ex()
    Dim R As Range, Rng As Range
    With ActiveSheet.UsedRange
        .Columns("M:Q").AdvancedFilter Action:=xlFilterInPlace, Unique:=True


Sub Ex1()
    Dim Sh As Worksheet, wb As Workbook
    Set Sh = ActiveSheet
    Sh.Copy
    Set wb = ActiveWorkbook
    With wb.Sheets(1)
        .UsedRange.Columns("M:Q").AdvancedFilter Action:=xlFilterInPlace, Unique:=True

改這兩邊嗎~TKS
作者: greetingsfromtw    時間: 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的內建的格式化條件設定,

去標出重複的值時,

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

需再跑第二次程式碼,

才會清除,

不知問題出在哪裡,

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



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