Speed up Loop VBA

**Rick Rothstein** · 04-09-2012, 12:44 AM

Originally Posted by PcMax

Performed a test with the macro Sub MarkPositionNumbers3.
Always measured under the same conditions.
I get the following results: 0.125 seconds.

Thanks for running the test. Admin's Dictionary method is still the winner, but the Collection method I just tried is not that far behind (all those CStr function calls during the loop iterations is what did it in)... at least it was faster than my other attempts, so some progress was made.

**PcMax** · 04-09-2012, 01:15 AM

Hi,

I need to store the total number of entries and I used: Application.CountIf.
I've seen what you can achieve with this code: CreateObject("scripting.dictionary") and I was wondering how to integrate the following request.

I enclose the working code that I tested:

Code:

Option Explicit

Declare Function GetTickCount Lib "kernel32" () As Long

Sub Okk()
    Dim Msec As Variant
    Dim Via, Avviso As Variant
    Via = GetTickCount
    Dim dic As Variant
    Dim cell As Variant
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    With dic
        For Each cell In Range("G2", Cells(Rows.Count, "G").End(xlUp))
            .Item(cell.Value) = .Item(cell.Value) + 1
        Next cell
        Range("M2").Resize(.Count, 1).Value = WorksheetFunction.Transpose(Array(.Items))
    End With
    Msec = GetTickCount - Via
    MsgBox "AVVISO: Tempo impiegato: " & Format$(Msec \ 3600000, "00") & ":" & Format$(((Msec - (Msec \ 3600000) * 3600000)) \ 60000, "00") & ":" & Format$((Msec - (Msec \ 60000) * 60000) / 1000, "00.000")
End Sub

While the following are not able to modify:

Code:

Option Explicit

Declare Function GetTickCount Lib "kernel32" () As Long

Sub NotOkk()
    Dim Msec As Variant
    Dim Via, Avviso As Variant
    Via = GetTickCount
    Dim r   As Long, dic As Object
    Dim Data As Variant
    Dim i As Long
    r = Range("G" & Rows.Count).End(xlUp).Row
    Data = Range("G2:G" & r)            'Original List
    ReDim Pos(1 To UBound(Data, 1), 1 To 1)
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1

    For i = 1 To UBound(Data, 1)
        Pos(i, 1) = dic.Item(Data(i, 1))
    Next
    Range("M2").Resize(UBound(Pos, 1)) = Pos
    Msec = GetTickCount - Via
    MsgBox "AVVISO: Tempo impiegato: " & Format$(Msec \ 3600000, "00") & ":" & Format$(((Msec - (Msec \ 3600000) * 3600000)) \ 60000, "00") & ":" & Format$((Msec - (Msec \ 60000) * 60000) / 1000, "00.000")
End Sub

Surely if something is not impossible to realize I'd rather it were integrated with previous data from the column count is the "G"

I also ask that the choice between the last 2 the best version that allows this change

**Admin** · 04-09-2012, 05:57 AM

Hi,

Code:

Option Explicit

Declare Function GetTickCount Lib "kernel32" () As Long

Sub NotOkk()
    Dim Msec As Variant
    Dim Via, Avviso As Variant
    Via = GetTickCount
    Dim r   As Long, dic As Object
    Dim Data As Variant
    Dim i As Long
    r = Range("G" & Rows.Count).End(xlUp).Row
    Data = Range("G2:G" & r)            'Original List
    ReDim Pos(1 To UBound(Data, 1), 1 To 1)
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1

    For i = 1 To UBound(Data, 1)
        dic.Item(Data(i, 1)) = dic.Item(Data(i, 1)) + 1'add the count
    Next
    Range("M2").Resize(dic.Count) = Application.Transpose(dic.items)
    Msec = GetTickCount - Via
    MsgBox "AVVISO: Tempo impiegato: " & Format$(Msec \ 3600000, "00") & ":" & Format$(((Msec - (Msec \ 3600000) * 3600000)) \ 60000, "00") & ":" & Format$((Msec - (Msec \ 60000) * 60000) / 1000, "00.000")
End Sub

**PcMax** · 04-09-2012, 12:34 PM

Hi,

Meanwhile, thank you all for the proposed solutions.
I had to edit the following line of code:

Code:

Range("M2").Resize(UBound(dic.Count, 1)) = Application.Transpose(dic.items)

Why report an error like: runtime - 13

I replaced it with:

Code:

Range("M2:M" & dic.Count + 1).Value = Application.Transpose(dic.items)

**Admin** · 04-09-2012, 03:27 PM

Hi

My bad

replace

Code:

Range("M2").Resize(UBound(dic.Count, 1))

with

Code:

Range("M2").Resize(dic.Count)

**PcMax** · 04-09-2012, 04:20 PM

Hi,

Yes, Admin, I was able to run it and it worked - so, thank you so very much!

Thread: Speed up Loop VBA

Thread Tools

Search Thread

Display

Similar Threads

VBA Code To Loop Cells In A Column One By One And Search In Another Sheet

VBA Trick of the Week :: Slicing an Array Without Loop - Application.Index

Vlookup Multiple Values By Adding Formula With Loop In VBA

data Transpose in VBA loop, choose the part I want to import!

Speed up excel to word VBA

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions