"Create a unique list and count of items from an unsorted list" Help

[Mahal]

A code submitted by mdmackillop:

[vba]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[/vba]

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!

[mdmackillop]

I must revisit that item!

[VBA]
Sub CountUnique()
Dim Rng1 As Range
With Sheets(1)
Set Rng1 = Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
End With
With Sheets(2)
Rng1.Copy .Cells(1, 7)
With Range(.Cells(1, 7), .Cells(1, 7).End(xlDown))
.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets(2).Range( _
"A2"), Unique:=True
.ClearContents
End With
Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Offset(, 1).FormulaR1C1 = _
"=COUNTIF(" & Sheets(1).Name & "!" & Rng1.Address(1, 1, -4150) & ",RC[-1])"
.Range("A1:B1") = Array("Number", "Quantity")
End With

End Sub

[/VBA]

[Mahal]

Thanks for the modified code mdmackillop! I tested it with my data, and it did its job so much faster than the other code.

However, I checked to see if it counted the unique numbers correctly and it did not. (I sorted the column of numbers myself...there were 1,250 copies of one number, but the quantity generated by the macro had the count at 1,248.)

I even did an autosum on the "Quantity" column, and I got a larger number than what I began with. I am working with 10,000 units, but when I added up the "Quantity" column, I got 11,205 units.

[Mahal]

Bumped hoping someone can help me with this situation:

In one worksheet, I have a column with 10,000 numbers. I would like to make a macro that will sort through the column, count all the unique numbers, and then post the results in a new worksheet.

I have already tried to use the code that was given, but the numbers were not counted correctly, and I do not know what to do to fix it.

Thank you for any help!

[mdmackillop]

Apologies. The filter copies the first item of the list as a "header" with the uniquie items below, so that the first item is being double counted. I've built in a simple fix to the code, and an Error Check
[vba]
Option Explicit

Sub CountUnique()
Dim Rng1 As Range, Rng2 As Range, Check As Long
With Sheets(1)
Set Rng1 = Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
End With
With Sheets(2)
Rng1.Copy .Cells(1, 7)
Sheets(2).Range("A1").ClearContents
With Range(.Cells(1, 7), .Cells(1, 7).End(xlDown))
.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets(2).Range( _
"A1"), Unique:=True
.ClearContents
End With
'For check
Set Rng2 = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
'Add formulae
Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Offset(, 1).FormulaR1C1 = _
"=COUNTIF(" & Sheets(1).Name & "!" & Rng1.Address(1, 1, -4150) & ",RC[-1])"
.Range("A1:B1") = Array("Number", "Quantity")
End With
'Error check
Check = Evaluate(Application.SumProduct(Rng2, Rng2.Offset(, 1))) - Application.Sum(Rng1)
If Check <> 0 Then
MsgBox "Error = " & Check
Else
MsgBox "Check OK"
End If
End Sub
[/vba]

[Northwolves]

Use Dictionary Object,you can get a high speed,As the following:
[VBA]
Sub macro1()
Dim arr, d As Object, i As Long
arr = Sheet1.[a1].Resize(Sheet1.[a65536].End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next
Sheet2.[a1:b1] = Split("Number Quantity")
Sheet2.[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
Sheet2.[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
Set d = Nothing
MsgBox "ok"
End Sub
[/VBA]

Best Regards
Northwolves

[mdmackillop]

Very neat.