Get count of duplicate strings from autofiltered range

[gtslabs]

I am using code from here: http://www.j-walk.com/ss/excel/tips/tip47.htm
to get a list of unique strings from an autofiltered range.
I can get the list ok but I need help getting a count of each
occurance.
I dont want a PivotTable, I need the code.
I tried the worksheet formula countif but it looked at all the rows
not the just the filtered one.
Please advise.


Private Sub GetDuplicateCount()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer

Set AllCells = Worksheets("Data").AutoFilter.Range.Columns(18)

On Error Resume Next
For Each Cell In AllCells.SpecialCells(xlVisible)
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a
string
Next Cell
' Resume normal error handling
On Error GoTo 0


' Add the unique items to a the Sheet
j = 1
For Each Item In NoDupes
Worksheets("Input").Cells(j, 13).Value = Item
' Worksheets("Input").Cells(j, 14).Value = itemcount 'Need help
with this.
j = j + 1
Next Item

End Sub

 

[Bernie Deitrick]

Try counting after creating the NoDupes list - see the macro below.

HTH,
Bernie
MS Excel MVP


Private Sub GetDuplicateCount2()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim item As Variant
Dim i As Integer, j As Integer
Dim myC As Range

Set AllCells = Worksheets("Data").AutoFilter.Range.Columns(18)

On Error Resume Next
For Each Cell In AllCells.SpecialCells(xlVisible)
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell
' Resume normal error handling
On Error GoTo 0

' Add the unique items to a the Sheet
j = 1
For Each item In NoDupes
Worksheets("Input").Cells(j, 13).Value = item
j = j + 1
Next item

'Count the occurences of the visible items
For Each Cell In AllCells.SpecialCells(xlVisible)
Set myC = Worksheets("Input").Cells(1, 13).EntireColumn.Find(Cell.Value)
myC.Offset(0, 1).Value = myC.Offset(0, 1).Value + 1
Next Cell

End Sub

 

[Dave Peterson]

First, did you mean to include the header from the autofilter range?

I'm guessing that you did not.

Option Explicit
Sub GetDuplicateCount()
Dim AllCells As Range
Dim AllVisCells As Range
Dim myCell As Range
Dim myArrVal As Variant
Dim myArrCtr As Variant
Dim aCtr As Long
Dim res As Variant

With Worksheets("data")
With .AutoFilter.Range
'avoid header????
Set AllCells _
= .Columns(18).Resize(.Rows.Count - 1, 1).Offset(1, 0)
End With
End With

Set AllVisCells = Nothing
On Error Resume Next
Set AllVisCells = AllCells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If AllVisCells Is Nothing Then
MsgBox "No visible detail rows"
Exit Sub '???
End If

aCtr = 0
For Each myCell In AllVisCells.Cells
If myCell.Value = "" Then
'skip it
Else
If IsArray(myArrVal) = False Then
'first cell in the range
aCtr = aCtr + 1
ReDim myArrVal(1 To aCtr)
myArrVal(aCtr) = myCell.Value

ReDim myArrCtr(1 To aCtr)
myArrCtr(aCtr) = 1
Else
'look for a match
res = Application.Match(myCell.Value, myArrVal, 0)
If IsError(res) Then
'not in the array, so add it
aCtr = aCtr + 1
ReDim Preserve myArrVal(1 To aCtr)
myArrVal(aCtr) = myCell.Value

ReDim Preserve myArrCtr(1 To aCtr)
myArrCtr(aCtr) = 1
Else
'it's there, so just update the counter
myArrCtr(res) = myArrCtr(res) + 1
End If
End If
End If
Next myCell

If aCtr = 0 Then
MsgBox "No non-empty cells were found!"
Else
'at least one non-empty cell was found
With Worksheets("Input")
.Range("M:N").ClearContents
.Range("M1").Resize(aCtr, 1).Value = Application.Transpose(myArrVal)
.Range("n1").Resize(aCtr, 1).Value = Application.Transpose(myArrCtr)
End With

End If

End Sub