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