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

ItalianPlatinum

Active Member
Joined
Mar 23, 2017
Messages
434
Office Version
  1. 2016
  2. 2010
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

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
58,194
Office Version
  1. 365
Platform
  1. Windows
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:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
58,194
Office Version
  1. 365
Platform
  1. Windows
Just checked another file with 843,630 rows of data & using a column that was all unique values, still only took 46 secs max.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,078
Office Version
  1. 365
Platform
  1. Windows
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?
 

ItalianPlatinum

Active Member
Joined
Mar 23, 2017
Messages
434
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

Just checked another file with 843,630 rows of data & using a column that was all unique values, still only took 46 secs max.
266,737 rows and 15mins.
 

ItalianPlatinum

Active Member
Joined
Mar 23, 2017
Messages
434
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
58,194
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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
 

ItalianPlatinum

Active Member
Joined
Mar 23, 2017
Messages
434
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
58,194
Office Version
  1. 365
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,132,781
Messages
5,655,253
Members
418,183
Latest member
skaufman

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
Top