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

terrykyo520

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欄重複值都寫不出來~...
例子圖

下載 (91.43 KB)

2015-8-10 16:04

Scott090

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

回復 2# Scott090


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

Scott090

回復 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. 
    
25. End Sub

複製代碼

terrykyo520

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

下載 (54.94 KB)

2015-8-11 11:45

TEST.rar (1.59 KB)

下載次數: 10

2015-8-11 11:47

Scott090

回復 5# terrykyo520


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

lpk187

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

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

回復 5# terrykyo520


    答案跟你的右圖一樣
test1.rar (9.04 KB)

下載次數: 11

2015-8-11 18:49

GBKEE

還有方法可試

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

複製代碼