刪除VBA中的所有重複行

Question

我正在查找如何使用VBA宏刪除所有重複行（當重複項存在於第一列時）。

當前Excel宏刪除所有重複實例除第一個實例外，這完全不是我想要的。我想絕對刪除。

Answer 1

存儲第一個實例的單元格供以後刪除。 然後去刪除重複，直到結束。

Dim F as integer, S as integer 'indices for First and Second cells to be compared 
Dim Deleted as boolean   'indicates if second line was deleted 
Dim First as Range, Second as Range 'First and second cells to be compared 
Dim Start as string     'Indicates the position of the first cell's start 

Start = "A1" 'can be as you like 
Set First = Sheet1.Range(Start) 'Sets the start cell 

F = 0   ' 
Do While First.Value <> "" 'loop while sheet contains data in the column 
    S = F + 1     'second cell is at least 1 cell below first cell 
    Deleted = false   'no second cell was deleted yet 
    Set Second = First.Offset(S,0)  'second cell is an offset of the first cell 

    Do While Second.Value <> ""  'loop while second cell is in sheet's range with data 
     if Second.Value = First.Value then 'if values are duplicade 
      Second.EntreRow.Delete    'delete second cell 
      Deleted = true      'stores deleted information 
     else        'if not, second cell index goes next 
      S = S + 1; 
     end if 

     Set Second = First.Offset(S, 0)  'sets second cell again (if deleted, same position, if not deleted, next position 
    Loop 

    if Deleted then   'if deleted, should delete first cell as well 
     First.EntireRow.Delete 
    else 
     F = F + 1   'if no duplicates found, first cell goes next 
    end if 

    Set First = Sheet1.Range(Start).Offset(F,0)  'sets first cell again (if deleted, same position, if not, next) 
Loop 

Answer 2

短一點的解決方案，以便快速上午的訓練做：

Sub quicker_Option() 

    Dim toDel(), i As Long 
    Dim RNG As Range, Cell As Long 
    Set RNG = Range("a1:a19") 'set your range here 

    For Cell = 1 To RNG.Cells.Count 
     If Application.CountIf(RNG, RNG(Cell)) > 1 Then 
      ReDim Preserve toDel(i) 
      toDel(i) = RNG(Cell).Address 
      i = i + 1 
     End If 
    Next 
    For i = UBound(toDel) To LBound(toDel) Step -1 
     Range(toDel(i)).EntireRow.Delete 

    Next i 

End Sub 

Answer 3

我使用此代碼創建總帳控制帳戶的自動對賬，如果用同等價值符號相反的任何小區是指切成片2;因此只留下對賬項目。

的代碼：

sub autoRecs() 
dim i as long 
Application.ScreenUpdating = False 
Application.StatusBar = True 
Dim i As Long 
Cells(5, 6).Select 
Dim x As Long 
Dim y As Long 
x = ActiveCell.Row 
y = x + 1 
Do Until Cells(x, 6) = 0 
Do Until Cells(y, 6) = 0 
Application.StatusBar = "Hey Relax! You can rely on me......" 
If Cells(x, 6) = Cells(y, 6) * -1 Then 
Cells(x, 6).EntireRow.Cut (Worksheets(2).Cells(x, 6).EntireRow) 
Cells(y, 6).EntireRow.Cut (Worksheets(2).Cells(y, 6).EntireRow) 
Cells(x, 6).Value = "=today()" 
Cells(y, 6).Value = "=today()" 
Else 
y = y + 1 
End If 
Loop 
x = x + 1 
y = x + 1 
Loop 
Application.StatusBar = False 
End Sub 

Sub deleteBlankCells()`this is to delete unnecessary cells after run the above macro` 
Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp)).Select 
For i = Selection.Rows.Count To 1 Step -1 
Application.StatusBar = "OOH! I'm cleaning all the blanks for you....." 
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then 
Selection.Rows(i).EntireRow.Delete 
End If 
Next i 
Application.StatusBar = False 
End Sub 

Answer 4

我喜歡內VBA陣列的工作，所以這裏是一個例子。

• 假設該數據表示圍繞A1的currentregion，但是，很容易改變
• 讀取源數據到一個數組
• 檢查在一列中的每個項目，以確保它是唯一的（即項目的COUNTIF = 1）
• 如果唯一，請將相應的行號添加到集合中
• 使用集合的大小和列數來調暗結果數組。
• 循環訪問集合，將相應的行寫入結果數組。
• 將結果數組寫入工作表。

正如所寫，結果放置在源數據的右側，但也可以替換它，或放置在不同的工作表上。

Option Explicit 
Sub RemoveDuplicatedRows() 
    Dim vSrc As Variant, vRes() As Variant 
    Dim rSrc As Range, rRes As Range 
    Dim colUniqueRows As Collection 
    Dim I As Long, J As Long 

'assume data starts in A1 and represented by currentregion 
Set rSrc = Range("a1").CurrentRegion 
vSrc = rSrc 

Set rRes = rSrc.Offset(0, UBound(vSrc, 2) + 2) 

'get collection of non-duplicated rows 
Set colUniqueRows = New Collection 
For I = 1 To UBound(vSrc) 
    If WorksheetFunction.CountIf(rSrc.Columns(1), vSrc(I, 1)) = 1 Then _ 
     colUniqueRows.Add I 
Next I 

'Make up results array 
ReDim vRes(1 To colUniqueRows.Count, 1 To UBound(vSrc, 2)) 
For I = 1 To UBound(vRes, 1) 
    For J = 1 To UBound(vSrc, 2) 
     vRes(I, J) = vSrc(colUniqueRows(I), J) 
    Next J 
Next I 

rRes.EntireColumn.Clear 
rRes.Resize(UBound(vRes)) = vRes 

End Sub