need some help pls with code that finds unique strings using script dictionary and provides a total/tally for one found

[kbishop94]

I have a starting point (thanks to Fluff for some time ago providing me the code shown below... but this code is executed in a different way plus it isn't looking within only visible cells, which is what I need this to do...)

so what I'm needing it to do is to have the code look in column "E" starting at row 21 and going down (looking in visible cells only) to the last cell found containing an entry (any entry, but it will always be a string no values):



So that the result in the target cells (column N and O starting at row 2) looks like this:


this is what I currently have (which doesn't work):

Dim Cl As Variant
Dim Va As Variant
Dim Obj As Object

ActiveWorkbook.Worksheets("REPORTS").Activate
Set Obj = CreateObject("scripting.dictionary")

    For Each Cl In Worksheets("REPORTS").Range("E21", Worksheets("REPORTS").Range("E" & Rows.Count).End(xlUp))
    
        If Not Obj.Exists(Cl.value) Then
            Obj.Add Cl.value, 1
        Else
            Obj.Item(Cl.value) = Obj.Item(Cl.value) + 1
        End If
    Next Cl

    For Each Va In Obj.Keys
      Worksheets("REPORTS").Range("O" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).value = Array(Va, Obj(Va))
    Next Va

ActiveWindow.SmallScroll Down:=-48
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("REPORTS").Range(Cells(2, 15), Cells(17, 15)).Select
ActiveWorkbook.Worksheets("REPORTS").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("REPORTS").Sort.SortFields.Add Key:=Range("O" & Rows.Count).End(xlUp), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("REPORTS").Sort
    .SetRange Range(Cells(2, 15), Cells(17, 15))
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Thanks for any help or suggestions that can allow me accomplish what I am trying to do

 

[Fluff]

Try

For Each Cl In Worksheets("REPORTS").Range("E21", Worksheets("REPORTS").Range("E" & Rows.Count).End(xlUp)).specialcells(xlvisible)

 

[Siddharth Rout]

When it comes to unique names, I prefer using Collections rather than Dictionaries as I do not have to check for the existance of a particular item. I have spoken about it in my video Collections and Dictionaries

I also see that you mentioned visible cells but you are not working with visible cells. See if this is what you are trying? I have commented the code so you should not have a problem understanding it. Still if you do then, simpy ask.

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim col As New Collection
    Dim itm As Variant
    Dim lRow As Long
    Dim rng As Range, aCell As Range
  
    '~~> Set this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("REPORTS")
      
    With ws
        '~~> Find last row
        lRow = .Range("E" & .Rows.Count).End(xlUp).Row
      
        '~~> Check if there are any visible cells
        '~~> Whenever you work with SpecialCells, it is a good habit to
        '~~> sandwhich it between On Error Resume Next and On Error GoTo 0
        On Error Resume Next
        Set rng = .Range("E21:E" & lRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
      
        If rng Is Nothing Then
            MsgBox "There are no visible cells in the range"
            Exit Sub
        End If
      
        '~~> Loop through visible cells and add them to collection using OERN
        For Each aCell In rng
            If Len(Trim(aCell.Value2)) <> 0 Then
                On Error Resume Next
                col.Add aCell.Value2, CStr(aCell.Value2)
                On Error GoTo 0
            End If
        Next aCell
    End With
  
    '~~> Display unique list
    For Each itm In col
        Debug.Print itm
    Next itm
End Sub

 

[kbishop94]

Try

For Each Cl In Worksheets("REPORTS").Range("E21", Worksheets("REPORTS").Range("E" & Rows.Count).End(xlUp)).specialcells(xlvisible)

Wow, I cant believe I didnt try that. I played around '.specialcells(xlvisible)' a number of ways trying to put it in different places and each time gettng an error. (I still cant beleive I failed to see the most obvious place it SHOULD of been. )

Regardless, thank you x1000 for fixing it for me (once again. )

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[kbishop94]

When it comes to unique names, I prefer using Collections rather than Dictionaries as I do not have to check for the existance of a particular item. I have spoken about it in my video Collections and Dictionaries

I also see that you mentioned visible cells but you are not working with visible cells. See if this is what you are trying? I have commented the code so you should not have a problem understanding it. Still if you do then, simpy ask.

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim col As New Collection
    Dim itm As Variant
    Dim lRow As Long, i As Long
    Dim rng As Range
    Dim aCell As Range
   
    '~~> Set this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("REPORTS")
       
    With ws
        '~~> Find last row
        lRow = .Range("E" & .Rows.Count).End(xlUp).Row
       
        '~~> Check if there are any visible cells
        On Error Resume Next
        Set rng = .Range("E21:E" & lRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
       
        If rng Is Nothing Then
            MsgBox "There are no visible cells in the range"
            Exit Sub
        End If
       
        '~~> Loop through visible cells and add them to collection using OERN
        For Each aCell In rng
            If Len(Trim(aCell.Value2)) <> 0 Then
                On Error Resume Next
                col.Add aCell.Value2, CStr(aCell.Value2)
                On Error GoTo 0
            End If
        Next aCell
    End With
   
    '~~> Display unique list
    For Each itm In col
        Debug.Print itm
    Next itm
End Sub

Thank you, Siddharth Rout. I have to step away here from my computer for a bit but as soon as I get back I will take a closer look at what you're suggesting and the code you provided.

 

[Fluff]

I prefer using Collections rather than Dictionaries as I do not have to check for the existance of a particular item

You don't need to with a dictionary in this instance, the code could simply be

    For Each Cl In Worksheets("REPORTS").Range("E21", Worksheets("REPORTS").Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlVisible)
         Obj.Item(Cl.Value) = Obj.Item(Cl.Value) + 1
    Next Cl

 

[Siddharth Rout]

You don't need to with a dictionary in this instance, the code could simply be

    For Each Cl In Worksheets("REPORTS").Range("E21", Worksheets("REPORTS").Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlVisible)
         Obj.Item(Cl.Value) = Obj.Item(Cl.Value) + 1
    Next Cl

Strange. Since morning, I am not getting any alerts like I used to. Nor am I getting emails if someone replies (Checked spam. nothing there as well). Did something change?

Yes Fluff, I agree, you can do that as well. But in this scenario, it is much simpler to use collections. much lesser code. But then this is just my opinion

 

[Fluff]

Strange. Since morning, I am not getting any alerts like I used to. Nor am I getting emails if someone replies.

Don't know about emails, as I have that turned off, but the notification alerts working for.

 

[Siddharth Rout]

Don't know about emails, as I have that turned off, but the notification alerts working for.

Notifications are working only if I refresh the page. Strange. Earlier, I instanltly used to see it. Will later try and clear cookies and see if that helps. Thanks again!