Mahal
04-08-2008, 11:59 AM
A code submitted by mdmackillop:
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
'Sort the selection into order
Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
DelCells = 0 'Count of deleted cells
Rw = 0 'Offset count
Val1 = ActiveCell.Value 'Initial value
Do While Val1 <> ""
DupCount = DupCount + 1
Val2 = ActiveCell.Offset(Rw).Formula
Val1 = ActiveCell.Offset(Rw + 1).Formula
'If cell = cell below then delete latter.
If Val1 = Val2 Then
ActiveCell.Offset(Rw + 1).Delete Shift:=xlUp
DelCells = DelCells + 1
Else
'If different, write count value and select next value
ActiveCell.Offset(Rw, 1) = DupCount
Rw = Rw + 1
DupCount = 0
End If
Loop
'Add cells to replace those deleted
With ActiveCell.End(xlDown).Offset(1)
For i = 1 To DelCells
.Insert Shift:=xlDown
Next
End With
'Add formula to total duplicate count
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
is almost exactly what I need, but it needs some tweaking.
1) How can you modify the code so that it would work efficiently with 10,000 items, since it is designed to deal with lists with less than 1,000 items.
2) Is there anyway that this function can be done on a different worksheet? In other words, I do not want the original column of numbers to be disturbed.
3) How can you add headings to the unique list and the count next to it? For example, in the end, it should look something like this:
<Name of Report>
Number (1st column)
123456
567890
213456
Quantity (2nd column)
5
3
7
Any help will be appreciated. Thank you so much!
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
'Sort the selection into order
Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
DelCells = 0 'Count of deleted cells
Rw = 0 'Offset count
Val1 = ActiveCell.Value 'Initial value
Do While Val1 <> ""
DupCount = DupCount + 1
Val2 = ActiveCell.Offset(Rw).Formula
Val1 = ActiveCell.Offset(Rw + 1).Formula
'If cell = cell below then delete latter.
If Val1 = Val2 Then
ActiveCell.Offset(Rw + 1).Delete Shift:=xlUp
DelCells = DelCells + 1
Else
'If different, write count value and select next value
ActiveCell.Offset(Rw, 1) = DupCount
Rw = Rw + 1
DupCount = 0
End If
Loop
'Add cells to replace those deleted
With ActiveCell.End(xlDown).Offset(1)
For i = 1 To DelCells
.Insert Shift:=xlDown
Next
End With
'Add formula to total duplicate count
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
is almost exactly what I need, but it needs some tweaking.
1) How can you modify the code so that it would work efficiently with 10,000 items, since it is designed to deal with lists with less than 1,000 items.
2) Is there anyway that this function can be done on a different worksheet? In other words, I do not want the original column of numbers to be disturbed.
3) How can you add headings to the unique list and the count next to it? For example, in the end, it should look something like this:
<Name of Report>
Number (1st column)
123456
567890
213456
Quantity (2nd column)
5
3
7
Any help will be appreciated. Thank you so much!