Excel VBA删除重复保留定位

Question

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

我想编辑我录到像宏：

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

但我不知道我是在正确的轨道

Answer 1

采用两套嵌套循环我在范围内检查每个细胞两次，一次，看是否它是一个重复的标记并第二次删除该值（确保删除所有重复项并且不会留下每个重复项的一个实例）。

我相信这是一种低效率的方法，但它的工作原理很有希望可以帮助同一船上的其他人。

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 2

在底部开始并朝工作最佳。获取单元值的十列条件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 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