- Mar 23, 2017
- Office Version
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