Option Explicit
Option Compare Text
Sub DupList()
Dim DelCells As Long, Rw As Long, DupCount As Long, i As Long
Dim Val1 As String, Val2 As String, SCell As String, ECell As String
Application.ScreenUpdating = False
Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
DelCells = 0
Rw = 0
Val1 = ActiveCell.Value
Do While Val1 <> ""
DupCount = DupCount + 1
Val2 = ActiveCell.Offset(Rw).Formula
Val1 = ActiveCell.Offset(Rw + 1).Formula
If Val1 = Val2 Then
ActiveCell.Offset(Rw + 1).Delete Shift:=xlUp
DelCells = DelCells + 1
Else
ActiveCell.Offset(Rw, 1) = DupCount
Rw = Rw + 1
DupCount = 0
End If
Loop
With ActiveCell.End(xlDown).Offset(1)
For i = 1 To DelCells
.Insert Shift:=xlDown
Next
End With
SCell = ActiveCell.Offset(0, 1).AddressLocal(False, False)
ECell = ActiveCell.End(xlDown).Offset(0, 1).AddressLocal(False, False)
Range(ECell).Offset(1).Formula = "=SUM(" & SCell & ":" & ECell & ")"
Application.ScreenUpdating = True
End Sub
|