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

 

[Peter_SSs]

Actually, the code did not produce the same results for me as my earlier code ... but if the OP is happy .. so am I.

 

[ZVI]

Not sure, but difference can be in the added d.CompareMode = 1 to exclude case sensetivety.
For regret there is no posted part of the correct data with the expected result to compare.