ItalianPlatinum
Well-known Member
- Joined
- Mar 23, 2017
- Messages
- 793
- Office Version
- 365
- 2019
- Platform
- 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