unique count of filtered data

[Danny54]

im having problems with the following vba code in my macro. If my filtered data has more than 1 row then the .Count is valid. If its only 1 or none found, the macro goes into a loop or at least it appears to be a look. I let it run for over a hour and it still was running when i stopped the macro. I've seen something about coding like this is bad.

Any suggestions?

what the code does is filter column 7 for the value Money. With the CreateObject piece, it counts only the unique values in Column A. Then I write the count to Sheet1.



ws.Range("A1:H999999").Select
Selection.AutoFilter
wb.ActiveSheet.Range("$A$1:$H999999").AutoFilter Field:=7, Criteria1:= _
"*Money*", Operator:=xlAnd

With CreateObject("scripting.dictionary")
For Each Cl In wb.ActiveSheet.Range("A2", wb.ActiveSheet.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
Debug.Print Range("A2", wb.ActiveSheet.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Address

If (Cl <> "Name") Then
.Item(Cl.Value) = Empty
End If
Next Cl
'MsgBox .Count
Worksheets("Sheet1").Cells(7, 12) = .Count
End With

wb.ActiveSheet.ShowAllData

 

[jasonb75]

is it because i have blank rows?

Shouldn't make a difference.

Empty rows should be ignored, blank rows (formulas that show a blank) will be filtered out as not meeting the filter criteria.

Either way, the last line of code that I suggested will return the correct range, the fact that it does means that there is a problem elsewhere, most likely somewhere in part of the code that you have not shown us.

 

[Danny54]

If you run the following you will see what i'm talking about. If the filter is something other than the data found in the first row (airplane) - the code runs fine and return the correct unique count of column A. If set to airplane it just sets in the Cl <> Color loop.


Option Explicit

Sub unique_count()

Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long
Dim Cl As Range

Set ws = ThisWorkbook.Sheets("Sheet3")
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Selection.AutoFilter
ThisWorkbook.ActiveSheet.Range("A1:B" & LastRow).AutoFilter Field:=2, Criteria1:= _
"*Airplane*", Operator:=xlAnd

With CreateObject("scripting.dictionary")
For Each Cl In ThisWorkbook.ActiveSheet.Range("A2", ThisWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlVisible)
If (Cl <> "Color") Then
.Item(Cl.Value) = Empty
End If
Next Cl
MsgBox .Count
End With

ActiveSheet.AutoFilterMode = False

End Sub


Data

Color Type
1 Orange Airplane
2 Red Car
3 Blue Car
4 Green Bus
5 Blue Car
6 Red Car

 

[jasonb75]

The order of events was wrong, you need to get the last row before filtering, if you had used code tags to format your code properly then I might have noticed it earlier. When you don't use tags the code becomes an unformatted mess that gets muddled in with the rest of your post and things are easily missed.

I've made a few changes below but have not tested it

Sub unique_count()

Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long
Dim Cl As Range, rng As Range

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet3")
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ThisWorkbook.ActiveSheet.Range("A1:B" & LastRow).AutoFilter Field:=2, Criteria1:= _
"*Airplane*", Operator:=xlAnd
Set rng = ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
With CreateObject("scripting.dictionary")
For Each Cl In rng
If (Cl <> "Color") Then
.Item(Cl.Value) = Empty
End If
Next Cl
MsgBox .Count
End With

End Sub

 

[Danny54]

Sweet.

I just tested and it now works with any value "thats" found and its correctly counting them.

However.... I get a message and the code stops if no values are found in this line with a message ... No cells were found

Set rng = ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
the intent here would be to return a 0

Thanks

 

[Danny54]

working the code this morning like below gives me what I need. Sorta looks goofy but a solution. I used your Intersect line from previous, then checked to see if it only return 1. if so, i bounce around the loop for unique values.... Poorly written.

Option Explicit

Sub unique_count()

Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long
Dim Cl As Range
Dim mycount As Long
Dim count As Long

Set ws = ThisWorkbook.Sheets("Sheet3")
LastRow = Cells(Rows.count, 1).End(xlUp).Row
ActiveSheet.AutoFilterMode = False
ThisWorkbook.ActiveSheet.Range("A1:B" & LastRow).AutoFilter Field:=2, Criteria1:= _
   "*Cars*", Operator:=xlAnd

With CreateObject("scripting.dictionary")
   For Each Cl In ThisWorkbook.ActiveSheet.Range("A2", ThisWorkbook.ActiveSheet.Range("A" & Rows.count).End(xlUp)).SpecialCells(xlVisible)
     mycount = Intersect(Columns(1), ActiveSheet.UsedRange).SpecialCells(xlCellTypeVisible).count - 1
     If mycount < 2 Then
      count = mycount
      Exit For
     End If
     If (Cl <> "Color") Then
       .Item(Cl.Value) = Empty
     End If
     count = .count
   Next Cl
End With

MsgBox count


ActiveSheet.AutoFilterMode = False

End Sub

 

[jasonb75]

Bit of a clean up for you

Option Explicit

Sub unique_count()
Dim cl As Range, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet3")
With ws
    .AutoFilterMode = False
    .Range("A1:B1").AutoFilter Field:=2, Criteria1:="*Car*", Operator:=xlAnd
    With CreateObject("scripting.dictionary")
        For Each cl In ws.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible)
            .Item(cl.Value) = Empty
        Next
        MsgBox .count - 1
    End With
    .AutoFilterMode = False
End With
End Sub

 

[Danny54]

Nice...

Thanks so much. Very clean and fast.

Have a wonderful day.