[英]VBA remove duplicates in two columns
我想使用VBA在B1 = B2 AND C1 = C2時刪除B和CEg兩列中的重復項,然后應刪除B2 AND C2數據。 但是,當B1!= B2 AND C1 = C2時,不應刪除B2 AND C2,因為B2的值與B1不同。 現在我正在使用下面的代碼,但是它並沒有做我想要的正確的事情。它僅刪除C列中的重復數據。
Sub ()
Dim rCell As Range
With Worksheets("Sheet1")
For Each rCell In Range("B1:C20")
rCell.EntireColumn.RemoveDuplicates 1
Next rCell
End With
End Sub
有誰知道如何更改代碼以使其正常工作?
提前致謝!
我讓你親密的...
Sub RemoveDups_Copy(sSheet As String)
Dim vArray As Variant
Dim x As Long, y As Integer
Dim sTest As String
Worksheets(sSheet).Select
x = 1
Do While Cells(x + 1, 1) <> ""
x = x + 1
Loop
lastRow = x
If lastRow = 1 Then lastRow = 2
lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim vArray(1 To lastRow, 1 To lastColumn)
Set dRemove = CreateObject("Scripting.Dictionary")
Set dRemoveIndex = CreateObject("Scripting.Dictionary")
For x = 2 To lastRow
sTest = ""
For y = 1 To lastColumn
sTest = sTest & "|" & Cells(x, y).Text
Next y
If dRemove(sTest) = "Remove" Then dRemoveIndex(x) = "Remove"
dRemove(sTest) = "Remove"
Next x
i = 0
For x = 1 To lastRow
If dRemoveIndex(x) <> "Remove" Then
i = i + 1
For y = 1 To lastColumn
vArray(i, y) = Cells(x, y).Text
Next y
End If
Next x
Range(Cells(2, 1), Cells(lastRow, lastColumn)).ClearContents
Call RemoveDups_Paste(1, 1, vArray)
End Sub
Sub RemoveDups_Paste(x As Integer, y As Integer, Arr As Variant)
Set Rng = Range(Cells(x, y), Cells(UBound(Arr, 1) - LBound(Arr, 1) + x, UBound(Arr, 2) - LBound(Arr, 2) + y))
Rng.Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, UBound(Arr, 2) - LBound(Arr, 2) + 1) = Arr
End Sub
這會將所有原始(或非重復)數據記錄到一個數組中,清除數據,然后將其粘貼為一個范圍,而不是單獨粘貼。 應該跑得快。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.