vba 删除VBA中的所有重复行

Removing ALL Duplicates Row in VBA

提问by user1599325

I am looking to find out how I can remove ALL duplicate rows (when duplicates exist in the first column) using a VBA macro.

我正在寻找如何使用 VBA 宏删除所有重复行（当第一列中存在重复项时）。

Currently Excel macros delete all duplicate instances EXCEPT for the first instance, which is totally not what I want. I want absolute removal.

目前 Excel 宏删除所有重复的实例，除了第一个实例，这完全不是我想要的。我要绝对删除。

回答by Kazimierz Jawor

A bit shorter solution done for quick morning training:

为快速晨训完成的更短的解决方案：

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

回答by syedkollol

I am using this code to create an Auto reconciliation of general ledger control accounts where if any cell with equal value but opposite sign is cut to sheet 2; hence left with only reconciliation item.

我正在使用此代码创建总帐控制帐户的自动对帐，如果任何具有相同值但符号相反的单元格被剪切到工作表 2；因此只剩下对帐项目。

the code:

编码：

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

回答by Ron Rosenfeld

I like to work with arrays within VBA, so here is an example.

我喜欢在 VBA 中使用数组，所以这里有一个例子。

• Assume the data represents the currentregion around A1, but that is easily changed
• Read the source data into an array
• Check each item in column one to ensure it is unique (countif of that item = 1)
• If unique, add the corresponding row number to a Collection
• Use the size of th collection and the number of columns to Dim a results array.
• Cycle through the collection, writing the corresponding rows to a results array.
• Write the results array to the worksheet.

• 假设数据代表 A1 周围的当前区域，但这很容易改变
• 将源数据读入数组
• 检查第一列中的每个项目以确保它是唯一的（该项目的计数 = 1）
• 如果唯一，则将相应的行号添加到集合中
• 使用集合的大小和列数对结果数组进行 Dim。
• 循环遍历集合，将相应的行写入结果数组。
• 将结果数组写入工作表。

As written, the results are placed to the right of the source data, but could also replace it, or be placed on a different sheet.

正如所写，结果放置在源数据的右侧，但也可以替换它，或放置在不同的工作表上。

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

回答by Daniel M?ller

Store the first instance's cell for later deleting. Then go deleting duplicates until the end.

存储第一个实例的单元格供以后删除。然后去删除重复直到最后。

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