我正在寻找如何使用 VBA 宏删除所有重复的行（当第一列中存在重复时）。
目前 Excel 宏会删除除第一个实例之外的所有重复实例，这完全不是我想要的。我要绝对删除。
【问题讨论】：
标签： vba excel duplicates
为快速晨练做了一个更短的解决方案：
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
【讨论】：
存储第一个实例的单元格以供以后删除。 然后去删除重复直到结束。
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
【讨论】：
我正在使用此代码创建总帐控制帐户的自动对帐，如果任何具有相同值但符号相反的单元格被剪切到表 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
【讨论】：
我喜欢在 VBA 中使用数组，所以这里有一个示例。
正如所写，结果放置在源数据的右侧，但也可以替换它，或放置在不同的工作表上。
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
【讨论】：