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

[ItalianPlatinum]

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?

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

 

[Fluff]

Thanks for that, wasn't sure if you had something else slowing things down when putting the data onto the sheet, but that isn't the case.
I think you are out of luck in making it any faster, unless it can be done with power query.

 

[ItalianPlatinum]

Thanks for that, wasn't sure if you had something else slowing things down when putting the data onto the sheet, but that isn't the case.
I think you are out of luck in making it any faster, unless it can be done with power query.

Sorry power query i have never done. is that the forum pete put above? and does it still use excel VBA?

 

[Fluff]

Yes it is the section Peter linked to & no it doesn't use VBA.

 

[Peter_SSs]

Is it possible for you to make a copy of your workbook with, say, 50,000 rows and with any sensitive data removed or disguised and
a) tell us how long the code took for you on that reduced workbook, and
b) upload that workbook to DropBox or OneDrive or Google drive etc and provide a shared link here?

That way we can be sure we are testing the same thing and it may turn something up that helps.

 

[ItalianPlatinum]

Is it possible for you to make a copy of your workbook with, say, 50,000 rows and with any sensitive data removed or disguised and
a) tell us how long the code took for you on that reduced workbook, and
b) upload that workbook to DropBox or OneDrive or Google drive etc and provide a shared link here?

That way we can be sure we are testing the same thing and it may turn something up that helps.

Peter I can try that just give me some time to create something that removes all the sensitive data.

 

[ZVI]

Hi,
The bottleneck can be in long string concatenating in this place: d(a(i, 1)) = d(a(i, 1)) & s
Try this modification of the code:

Sub UniqueCount1()

  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long

  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")
    d.CompareMode = 1

    On Error Resume Next  ' To ignore error for duplicated items in collection
    For i = 1 To UBound(a)
      If Not d.Exists(a(i, 1)) Then
        Set d.Item(a(i, 1)) = New Collection
      End If
      d.Item(a(i, 1)).Add 0, a(i, 2)
    Next
    On Error GoTo 0

    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) = d(Ky).Count
      Set d(Ky) = New Collection ' Force memory clearing (exclude memory leaking in case of big collection)
      Set d(Ky) = Nothing
    Next

  End With

  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    i = .EntireColumn.Cells(.Parent.Rows.Count, 1).End(xlUp).Row - .Row
    If i > 0 Then .Offset(1).Resize(i, 2).ClearContents
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(UBound(a), 2).Value = a
  End With

  ' Release memory of the dictionary object
  d.RemoveAll
  Set d = Nothing

End Sub

 

[ItalianPlatinum]

Hi,
The bottleneck can be in long string concatenating in this place: d(a(i, 1)) = d(a(i, 1)) & s
Try this modification of the code:

Sub UniqueCount1()

  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long

  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")
    d.CompareMode = 1

    On Error Resume Next  ' To ignore error for duplicated items in collection
    For i = 1 To UBound(a)
      If Not d.Exists(a(i, 1)) Then
        Set d.Item(a(i, 1)) = New Collection
      End If
      d.Item(a(i, 1)).Add 0, a(i, 2)
    Next
    On Error GoTo 0

    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) = d(Ky).Count
      Set d(Ky) = New Collection ' Force memory clearing (exclude memory leaking in case of big collection)
      Set d(Ky) = Nothing
    Next

  End With

  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(UBound(a), 2).Value = a
  End With

  ' Release memory of the dictionary object
  d.RemoveAll
  Set d = Nothing

End Sub

I think that is it. It yielded the same results as the prior and took 4mins. Previous logs it was taking 18min, 17min, 19min. So i can chalk up the 4min on all the other processes i have it doing. Thank you so much! Working great. I will negative test it tomorrow to make sure it still works.

 

[Peter_SSs]

The bottleneck can be in long string concatenating in this place: d(a(i, 1)) = d(a(i, 1)) & s
Try this modification of the code:

Hi Vlad
Sounds like you might have cracked this. Great insight & thanks for chiming in!!

 

[ZVI]

Hi Vlad
Sounds like you might have cracked this. Great insight & thanks for chiming in!!

Hi Peter and thank you!
But actually I was hoping on a few seconds performance , seems strings in the range are too long.
And you are right that uploaded example can help in the performance analyzing.

 

[ZVI]

I think that is it. It yielded the same results as the prior and took 4mins. Previous logs it was taking 18min, 17min, 19min. So i can chalk up the 4min on all the other processes i have it doing. Thank you so much! Working great. I will negative test it tomorrow to make sure it still works.

You are welcome!
One step forward. As Peter wrote, your sample of workbook with similar data can help in finding of a better solution.

P.S. Code in the post #16 was a bit updated - clearing of the destination range is added.