删除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