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

#### ItalianPlatinum

##### Active Member
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
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
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
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

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
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

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
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
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

#### ItalianPlatinum

##### Active Member
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
876.76171875
876.763671875
884.89453125
884.896484375

Replies
0
Views
101
Replies
1
Views
284
Replies
18
Views
330
Replies
1
Views
87
Replies
0
Views
81

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?

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