下面的代码目前正在删除所有重复出现,包括在A栏中找到的原始出现。我想修改下面的代码,删除基于A,B,C和A列的所有重复项。 D.为了澄清,对于第1行和第2行,如果列A匹配,B匹配,c匹配和d匹配两行将被删除。有人能帮忙吗?我相信这里需要一个阵列,但不确定如何。谢谢!
Dim toDel5(), p As Long
Dim RNG5 As Range, Cell5 As Long
Set RNG5 = Range("a1:a4000") 'set your range here
For Cell5 = 1 To RNG5.Cells.Count
If Application.CountIf(RNG5, RNG5(Cell5)) > 1 Then
ReDim Preserve toDel5(p)
toDel5(p) = RNG5(Cell5).Address
p = p + 1
End If
Next
On Error GoTo NO_DUPLICATES
For p = UBound(toDel5) To LBound(toDel5) Step -1
Range(toDel5(p)).EntireRow.Delete
Next p
On Error GoTo 0
End With
NO_DUPLICATES:
答案 0 :(得分:1)
此问题似乎需要自定义算法。不确定前面提到的RemoveDuplicates
是否可以为一个不那么简单的案例提供可靠的答案,但在这种情况下我更喜欢从头开始创建一些东西。至于你的代码不太灵活,我找不到提出修正的方法,因此我创建了整个循环(我不该做的)。请注意,此代码可以适应任意数量的分析列/行。还要记住,它依赖于准时删除目标单元格(而不是删除整行,只能在循环外执行);这只是为了向您展示另一种替代解决方案;您可以根据需要更改此代码。
Dim maxRow As Long
Dim curStep, startColumn, endColumn As Integer
Dim areDuplicated As Boolean
curStep = 2 'No of rows to be considered
startColumn = 1
endColumn = 4
maxRow = 4000
For curRow = 1 To maxRow - 1
areDuplicated = True
For curColumn = startColumn To endColumn
For curRow2 = curRow + 1 To curRow + curStep - 1
If (IsEmpty(RNG5.Cells(curRow, curColumn)) Or RNG5.Cells(curRow, curColumn) <> RNG5.Cells(curRow2, curColumn)) Then
areDuplicated = False
Exit For
End If
If (Not areDuplicated) Then
Exit For
End If
Next
Next
If (areDuplicated) Then
For curRow3 = curRow To curRow + curStep - 1
For curCol3 = startColumn To endColumn
RNG5.Cells(curRow3, curCol3).Value = ""
Next
Next
End If
Next
答案 1 :(得分:0)
感谢Varo Carbs,这比我最终使用的代码要简单一些。我使用的代码如下,以防有人想看到另一个选项。谢谢你的帮助!
Dim r As Long, c As Long, n As Long, x As Long
Dim rData As Range
Application.ScreenUpdating = False
n = ActiveSheet.Cells(1, 1).CurrentRegion.Columns.Count + 1
ActiveSheet.Cells(1, n).Value = "TEMP"
For r = 2 To ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count
ActiveSheet.Cells(r, n).Value = r
Next r
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
With ActiveSheet.Sort
.SortFields.Clear
For c = 1 To n
.SortFields.Add Key:=rData.Cells(1, c).Resize(rData.Rows.Count - 1, 1)
Next c
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With rData
For r = 2 To .Rows.Count
x = 0
For c = 1 To n
If .Cells(r, c).Value <> .Cells(r + 1, c).Value Then
x = x + 1
Exit For
End If
Next c
If x = 0 Then
.Cells(r, n).Value = True
.Cells(r + 1, n).Value = True
End If
Next r
End With
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Cells(1, n).Resize(rData.Rows.Count - 1, 1)
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
On Error Resume Next
rData.Columns(n).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error Goto 0
rData.Columns(n).EntireColumn.Delete
Application.ScreenUpdating = True