Page 2 of 2 FirstFirst 12
Results 11 to 16 of 16

Thread: Speed up Loop VBA

  1. #11
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    659
    Rep Power
    13
    Quote Originally Posted by PcMax View Post
    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.

  2. #12
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    13
    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

  3. #13
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,122
    Rep Power
    10
    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
    Last edited by Admin; 04-09-2012 at 03:29 PM. Reason: code corrected
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  4. #14
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    13
    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)
    The routine works fine
    Last edited by PcMax; 04-09-2012 at 12:37 PM.

  5. #15
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,122
    Rep Power
    10
    Hi

    My bad

    replace

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

    Code:
    Range("M2").Resize(dic.Count)
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  6. #16
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    13
    Hi,

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

Similar Threads

  1. Replies: 1
    Last Post: 06-12-2013, 07:42 PM
  2. VBA Trick of the Week :: Slicing an Array Without Loop - Application.Index
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 06-12-2013, 04:40 PM
  3. Vlookup Multiple Values By Adding Formula With Loop In VBA
    By Safal Shrestha in forum Excel Help
    Replies: 15
    Last Post: 04-22-2013, 04:49 PM
  4. Replies: 2
    Last Post: 04-16-2013, 01:36 PM
  5. Speed up excel to word VBA
    By bcostin in forum Excel Help
    Replies: 3
    Last Post: 05-22-2012, 10:49 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •