Excel VBA删除重复保留定位

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

我试图编辑我logging的macros像这样的：

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

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

Answer 1

从底部开始，朝着顶部努力。 采用单元值的十列条件COUNTIFS函数 ，同时缩短每个循环所检查的行数。

 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 (ie 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

使用条件格式突出显示重复项，然后使用循环select将值更改为“”。 这个代码将允许保留一个值（如果你有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