Increase result speed - List unique values and its count and percentage to total

[anishms]

Hi,
I have below code to take the unique values from a selected column and show the count and percentage of each unique values in the total rows of data.
Request help on the area where the looping happens from first row to last row for all the unique values which make the result slow / even excel stuck if the number of unique values are more. For example column "ID". Can somebody help me with a better code to increase the speed of results.

Sub ViewUnique_Click()

    If combx_Fields.ListIndex < 0 Then
        MsgBox "Oops! You missed to choose the column heading.", vbInformation
        Exit Sub
    End If
    
    Dim j      As Long, cntArray As Long, iUnique As Long, iTotal As Long
    Dim aryList() As Variant
    
    
    ReDim aryList(1 To numUnique + 2, 0 To 2)
    aryList(1, 0) = "Unique Values"
    aryList(1, 1) = "Count"
    aryList(1, 2) = "Percentage"
    
    Load UF_UniqueList
    
    For iUnique = 1 To numUnique
        cntArray = 0
        
        For j = rowFirst + 1 To rowLast
            If UCase(wsData.Cells(j, ColumnPicked).Value) = UCase(UniqueList(iUnique)) Then
                cntArray = cntArray + 1
            End If
        Next j
        
        aryList(iUnique + 1, 0) = UniqueList(iUnique)
        aryList(iUnique + 1, 1) = cntArray
        iTotal = iTotal + cntArray
        aryList(iUnique + 1, 2) = Format(cntArray / numRowsOfData, "0.00%")
        
    Next iUnique
    
    aryList(numUnique + 2, 0) = "Total"
    aryList(numUnique + 2, 1) = iTotal
    aryList(numUnique + 2, 2) = "100%"
    
    UF_UniqueList.ListBox1.ColumnCount = UBound(aryList, 2) + 1
    UF_UniqueList.ListBox1.List = aryList
    UF_UniqueList.Show
    
End Sub

 

[p45cal]

This is what's taking a long time (it repeatedly reads from the worksheet).

        For j = rowFirst + 1 To rowLast
            If UCase(wsData.Cells(j, ColumnPicked).Value) = UCase(UniqueList(iUnique)) Then
                cntArray = cntArray + 1
            End If
        Next j

Either:
put rdata into an array of values (rDataVals=rData.value) and work on that
or:
replace those 5 lines of code with:

cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), UniqueList(iUnique))

which only looks at the sheet once. Countifs is not case sensitive.

 

[anishms]

Thanks p45cal!
Yes, count if has increased the speed drastically. But it is not counting the first column which is a date

 

[p45cal]

In the line:
UniqueList.Add CStr(myrange), CStr(myrange)
you coerce both the object and the key to strings; instead use:
UniqueList.Add myrange.Value, CStr(myrange)
where only the key is coerced to a string.

Now Countifs should work with dates.

 

[anishms]

Thanks p45cal!
Perfectly working

 

[anishms]

Hi p45cal,
Its not counting blanks and I have one more problem as highlighted below-
The actual count of >60 days is 1. How can I fix that?
I had to put a "." before the symbol ">" to get the actual count
I also need to count the blanks

 

[p45cal]

An interesting gotcha, where the > symbol at the beginning of a string is being taken as being an operator!
Two solutions:
1. Avoid having <, > or = at the beginning of your cells in the TAT column (this you've done with your dot).
or:
2. Change:

cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), UniqueList(iUnique))

to:

  If IsError(Application.Match(Left(UniqueList(iUnique), 1), Array("<", ">", "="), 0)) Then
    cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), UniqueList(iUnique))
  Else
    cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), "*" & UniqueList(iUnique))
  End If

which says if the string you're looking for starts with <,>, or =, look for strings ending with string. This means it'll still work with dates and numbers. It seems to work but double-check it.

 

[anishms]

Thanks p45cal!
Its working for the ">" but still the blank cells are not counted

 

[p45cal]

still the blank cells are not counted

Oops, missed that.
Change that bit of code to:

  If IsError(Application.Match(Left(UniqueList(iUnique), 1), Array("<", ">", "="), 0)) Then
    If UniqueList(iUnique) = Empty Then
      cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), "")
    Else
      cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), UniqueList(iUnique))
    End If
  Else
    cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), "*" & UniqueList(iUnique))
  End If

This will give the count of cells resolving to "", cells with a single or double space (or more) will still be counted separately, leading to results like:

where one of the blanks is a count of empty cells, another is a count of single space cells and another the count of double-space cells.

 

[anishms]

Thanks a lot p45cal!

 

[anishms]

How can I show the "" as (blank) like pivot tables in the list box here.

    If UniqueList(iUnique) = Empty Then
      cntArray = Application.CountIfs(Range(wsData.Cells(rowFirst, ColumnPicked), wsData.Cells(rowLast, ColumnPicked)), "")
      UniqueList(iUnique) = "(blank)"

But I don't want to do it in the collect list like below

        For Each myrange In .Range(.Cells(rowFirst + 1, ColumnPicked), .Cells(rowLast, ColumnPicked))
            If myrange = Empty Then
                UniqueList.Add "(blank)", CStr(myrange)
            Else
                UniqueList.Add myrange.Value, CStr(myrange)
            End If
        Next

 

[p45cal]

change:

  aryList(iUnique + 1, 0) = UniqueList(iUnique)

to:

  If UniqueList(iUnique) = Empty Then aryList(iUnique + 1, 0) = "(blank)" Else aryList(iUnique + 1, 0) = UniqueList(iUnique)

 

[anishms]

Thanks p45cal!