Count unique values based off criteria -- Existing code works too long to run

ItalianPlatinum

Well-known Member
Joined
Mar 23, 2017
Messages
733
Office Version
  1. 2021
  2. 2019
  3. 2016
  4. 2010
  5. 2007
Platform
  1. Windows
Hello - I have the below VBA embedded into my long process. it works as designed problem is. my VBA in total takes 18mins; but this one section in the code itself takes 15min of it. Is there any other way or improvement within the code someone could see to speed it up?

VBA Code:
Sub UniqueCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long
  Dim s As String
  Dim wsDest As Worksheet
 
  Const ResultWorkbook As String = "COMPARSION.xlsm"  '<- Edit to suit
  Const ResultWorksheet As String = "main"   '<- Edit to suit
  Const ResultTopLeft As String = "J5"          '<- Where you want the results
  Const CritColValCol As String = "3 5"         '<- Criteria column & Values column in that order. Edit to suit.
 
  With Workbooks("_ALL.xlsm").Sheets("Post Rel")
    lastrw = .Cells(.rows.count, CLng(Split(CritColValCol)(0))).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lastrw & ")"), Split(CritColValCol))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      s = "|" & a(i, 2) & "|"
      If InStr(1, d(a(i, 1)), s, 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & s
    Next i
    ReDim a(1 To d.count, 1 To 2)
    i = 0
    For Each Ky In d.Keys()
      i = i + 1
      a(i, 1) = Ky: a(i, 2) = UBound(Split(d(Ky), "||")) + 1
    Next Ky
    
  End With
  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(d.count, 2).Value = a
  End With
End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
How much data are you working with?
With ~300,000 rows it takes me a max of 6secs with all 300,000 values unique
down to 1.1secs where there are only 105 distinct values
 
Last edited:
Upvote 0
Just checked another file with 843,630 rows of data & using a column that was all unique values, still only took 46 secs max.
 
Upvote 0
That code looks very familiar to me. :)

I did two tests with 900,000 rows.

First test had every row being a unique combination in the two columns and my machine took 76 seconds

Second test I assume was a bit more realistic. Random data that resulted in 1,000 unique values in the Vs column with each of those 1,000 values having an average of 600 unique values in the Trans column. For that circumstance the code ran in 20 seconds.

If it is taking 15 minutes for you my first guess is that your machine has less resources than mine or Fluff's. In any case, for me it is still as I stated in your other thread.
There is a lot of work to be done to get the results. Sorry, a faster way to get them is not apparent to me.

Perhaps it might be worth asking in the Power BI Forum. That may well provide a faster result?
 
Upvote 0
That code looks very familiar to me. :)

I did two tests with 900,000 rows.

First test had every row being a unique combination in the two columns and my machine took 76 seconds

Second test I assume was a bit more realistic. Random data that resulted in 1,000 unique values in the Vs column with each of those 1,000 values having an average of 600 unique values in the Trans column. For that circumstance the code ran in 20 seconds.

If it is taking 15 minutes for you my first guess is that your machine has less resources than mine or Fluff's. In any case, for me it is still as I stated in your other thread.


Perhaps it might be worth asking in the Power BI Forum. That may well provide a faster result?
Yes pete it should. its awesome. just that time hurts, the data is 437k rows. 42 columns with a lot of duplicate records that rationale for counting unique values. My PC is actually very fast so I hope that isn't the avenue we are thinking.
 
Upvote 0
If you add the parts in red, what does the immediate window say after the code has run?
Rich (BB code):
Sub UniqueCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long
  Dim s As String
  Dim wsDest As Worksheet
  Dim t As Double
  
t = Timer
  Const ResultWorkbook As String = "COMPARSION.xlsm"  '<- Edit to suit
  Const ResultWorksheet As String = "main"   '<- Edit to suit
  Const ResultTopLeft As String = "J5"          '<- Where you want the results
  Const CritColValCol As String = "3 5"         '<- Criteria column & Values column in that order. Edit to suit.
 
  With Workbooks("_ALL.xlsm").Sheets("Post Rel")
    lastrw = .Cells(.Rows.Count, CLng(Split(CritColValCol)(0))).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lastrw & ")"), Split(CritColValCol))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      s = "|" & a(i, 2) & "|"
      If InStr(1, d(a(i, 1)), s, 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & s
    Next i
    ReDim a(1 To d.Count, 1 To 2)
    i = 0
    For Each Ky In d.Keys()
      i = i + 1
      a(i, 1) = Ky: a(i, 2) = UBound(Split(d(Ky), "||")) + 1
    Next Ky
    
  End With
Debug.Print Timer - t
  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(d.Count, 2).Value = a
  End With
Debug.Print Timer - t
End Sub
 
Upvote 0
If you add the parts in red, what does the immediate window say after the code has run?
Rich (BB code):
Sub UniqueCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long
  Dim s As String
  Dim wsDest As Worksheet
 Dim t As Double
  
t = Timer
  Const ResultWorkbook As String = "COMPARSION.xlsm"  '<- Edit to suit
  Const ResultWorksheet As String = "main"   '<- Edit to suit
  Const ResultTopLeft As String = "J5"          '<- Where you want the results
  Const CritColValCol As String = "3 5"         '<- Criteria column & Values column in that order. Edit to suit.

  With Workbooks("_ALL.xlsm").Sheets("Post Rel")
    lastrw = .Cells(.Rows.Count, CLng(Split(CritColValCol)(0))).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lastrw & ")"), Split(CritColValCol))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      s = "|" & a(i, 2) & "|"
      If InStr(1, d(a(i, 1)), s, 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & s
    Next i
    ReDim a(1 To d.Count, 1 To 2)
    i = 0
    For Each Ky In d.Keys()
      i = i + 1
      a(i, 1) = Ky: a(i, 2) = UBound(Split(d(Ky), "||")) + 1
    Next Ky
   
  End With
Debug.Print Timer - t
  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(d.Count, 2).Value = a
  End With
Debug.Print Timer - t
End Sub
There was no message. was there suppose to be?
 
Upvote 0
You need to look in the immediate window, usually found below the code window, Ctrl G will bring it up if it's not there
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top