Excel VBA删除重复项保持定位

Question

有人可以帮助我使用一些代码来删除跨多列和多行的所有重复条目。任何具有重复值的单元格我都希望为空白，但我不想删除单元格并将所有行向上移动，就像删除重复按钮一样。我希望代码与条件格式完全相同以突出显示单元格，但我想将值设置为“”。

我正在尝试将录制的宏编辑为：

Columns("I:R").Select
    selection.FormatConditions.AddUniqueValues
    selection.FormatConditions(1).DupeUnique = xlDuplicate
    selection.FormatConditions(1).Value = ""

但我不确定我是否走在正确的轨道上

Answer 1

从底部开始，向顶部工作。获取单元格值的十列条件COUNTIFS function，同时将每个循环检查的行缩短 1。

Sub clearDupes()
    Dim rw As Long

    With Worksheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        With Intersect(.Range("I:R"), .UsedRange)
            .Cells.Interior.Pattern = xlNone
            For rw = .Rows.Count To 2 Step -1
                With .Resize(rw, .Columns.Count)  'if clear both then remove this
                    If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
                                            .Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
                                            .Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
                                            .Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
                                            .Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then

                        'test with this
                        .Rows(rw).Cells.Interior.Color = vbRed
                        'clear values with this once it has been debugged
                        '.Rows(rw).Cells.ClearContents
                    End If
                End With  'if clear both then remove this
            Next rw
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
End Sub

我留下了一些代码，只标记潜在的重复项。如果您对结果感到满意，请将其更改为实际清除单元格内容的注释代码。

Answer 2

使用两组嵌套循环，我检查范围内的每个单元格两次，一次是查看它是否重复并标记它，第二次是删除该值（确保删除所有重复项并且不留下一个每个副本的实例）。

我确信这是一种低效的方法，但它确实有效，因此希望可以帮助同一条船上的其他人。

Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer

Row = 100
Column = 10

'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
    For j = 1 To Column 'loops every column in each cell
        If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
            Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
        End If
    Next j
Next i

'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
    For j = 1 To Column 'loops every column in each cell
        If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
            Cells(i, j) = "" 'sets it to blank
            Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
        End If
    Next j
Next i

End Sub

Answer 3

使用条件格式突出显示重复项，然后使用循环选择将值更改为“”。 此代码将允许保留一个值。（如果您有两次 25，此代码将保留一个 25）

Option Explicit

Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)

For Each rn In Columns("I:R").Cells

If rn <> "" Then
   If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
     If dup Is Nothing Then
     Set dup = rn
     Else
     Set dup = Union(dup, rn)
     End If
   End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete

Application.ScreenUpdating = True
End Sub