Page 1 of 2 12 LastLast
Results 1 to 10 of 16

Thread: Speed up Loop VBA

  1. #1
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    14

    Speed up Loop VBA

    Hi,

    I have a column with numeric data and a function of a search for unique data would assign the position.
    The code should work with 200,000 rows and 20,000 different values (all listed)

    Unique list:
    123.20
    11.40
    34.00
    12.10

    Column G
    123.20
    11.40
    123.20
    34.00
    11.40
    12.10
    ---------------
    Unique list:
    123.20 |1
    11.40 |2
    123.20 |1
    34.00 |3
    11.40 |2
    12.10 |4

    I attach an example to improve.

    Code:
    Sub Add_Value()
        Dim row As Long, descr As String
        Application.ScreenUpdating = False
        row = 2
        Do While Cells(row, "G").Value <> ""
            Select Case Cells(row, "G").Value
                Case 123.20: descr = 1
                Case 11.40: descr = 2
                Case 34.00: descr = 3
                Case 12.10: descr = 4
                'Ecc...
    '            Case Else: descr = ""
            End Select
            Cells(row, "H").Value = descr
            row = row + 1
        Loop
        Application.ScreenUpdating = True
        
    End Sub
    Last edited by PcMax; 04-07-2012 at 04:21 PM.

  2. #2
    Senior Member
    Join Date
    Apr 2011
    Posts
    190
    Rep Power
    14
    Below is an example of code I use to find values - if a value exists more than once - then you have to loop - just be carefull as it will continue to loop back to where you started. My code below looks in a configuration sheet - then reads the value of that variable - two columns over - so modify the code to suit. But if you Google Foundcell - you will see lots of examples.

    Code:
            Astr = ValueToFind
            RangeVal = "A1:" & Split(Cells(1, ColLast).Address, "$")(1) & LastRow
            With .Range(RangeVal)
                Set LastCell = .Cells(.Cells.Count)
            End With
            Set FoundCell = .Range(RangeVal).Find(What:=(Astr), after:=LastCell)
            If FoundCell Is Nothing Then
                    Astr = ValueToFind
                    Call Message106(Astr)
                Else
                    ColDefault = FoundCell.Column + 2
                    RowDefault = FoundCell.Row
                    ReadValue = .Cells(FoundCell.Row, FoundCell.Column + 2)
            End If
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://eileenslounge.com/viewtopic.php?p=317218#p317218
    https://eileenslounge.com/viewtopic.php?p=316955#p316955
    https://eileenslounge.com/viewtopic.php?p=316955#p316955
    https://eileenslounge.com/viewtopic.php?p=316940#p316940
    https://eileenslounge.com/viewtopic.php?p=316927#p316927
    https://eileenslounge.com/viewtopic.php?p=317014#p317014
    https://eileenslounge.com/viewtopic.php?p=317006#p317006
    https://eileenslounge.com/viewtopic.php?p=316935#p316935
    https://eileenslounge.com/viewtopic.php?p=316875#p316875
    https://eileenslounge.com/viewtopic.php?p=316254#p316254
    https://eileenslounge.com/viewtopic.php?p=316280#p316280
    https://eileenslounge.com/viewtopic.php?p=315915#p315915
    https://eileenslounge.com/viewtopic.php?p=315512#p315512
    https://eileenslounge.com/viewtopic.php?p=315744#p315744
    https://www.eileenslounge.com/viewtopic.php?p=315512#p315512
    https://eileenslounge.com/viewtopic.php?p=315680#p315680
    https://eileenslounge.com/viewtopic.php?p=315743#p315743
    https://www.eileenslounge.com/viewtopic.php?p=315326#p315326
    https://www.eileenslounge.com/viewtopic.php?f=30&t=40752
    https://eileenslounge.com/viewtopic.php?p=314950#p314950
    https://www.eileenslounge.com/viewtopic.php?p=314940#p314940
    https://www.eileenslounge.com/viewtopic.php?p=314926#p314926
    https://www.eileenslounge.com/viewtopic.php?p=314920#p314920
    https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 05-20-2024 at 04:04 PM.
    xl2007 - Windows 7
    xl hates the 255 number

  3. #3
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Assuming the data values in Column "G" are all are constants (that is, there are no formulas in Column G), this macro should do what you want...

    Code:
    Sub MarkPositionNumbers()
      Dim X As Long, LastUniqueRow As Long
      Const DataColumn As String = "G"
      Const UniqueColumn As String = "A"
      Const FirstUniqueRow As Long = 2
      LastUniqueRow = Cells(Rows.Count, UniqueColumn).End(xlUp).Row
      On Error Resume Next
      Application.ScreenUpdating = False
      For X = FirstUniqueRow To LastUniqueRow
        With Columns(DataColumn)
          .Replace Cells(X, UniqueColumn).Value, "#N/A", xlWhole
          With .SpecialCells(xlConstants, xlErrors)
            .Offset(, 1).Value = X - FirstUniqueRow + 1
            .Value = Cells(X, UniqueColumn).Value
          End With
        End With
      Next
      Application.ScreenUpdating = True
    End Sub
    However, with the number of unique and data values being processed, I do not have a feel for how long it will take for this macro to execute.

    Note: You should look at the three Const statements and make sure the values I assign to them matches your actual setup.

  4. #4
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    I don't have a database anywhere near as large as what you indicated you will be working with, so I cannot test the speed difference out between the code I posted earlier (which should be about as fast as you will be able to find), but it is possible that the code below will execute even faster. You should make a copy of your workbook and test both out, using whichever one executes quicker for you.

    Code:
    Sub MarkPositionNumbers2()
      Dim X As Long, Z As Long, LastUniqueRow As Long, LastDataRow As Long
      Dim Uniques As Variant, Data As Variant, Positions As Variant
      Const DataColumn As String = "G"
      Const UniqueColumn As String = "A"
      Const FirstUniqueRow As Long = 2
      LastDataRow = Cells(Rows.Count, DataColumn).End(xlUp).Row
      LastUniqueRow = Cells(Rows.Count, UniqueColumn).End(xlUp).Row
      Uniques = Cells(FirstUniqueRow, UniqueColumn).Resize(LastUniqueRow - FirstUniqueRow + 1)
      Data = Cells(1, DataColumn).Resize(LastDataRow)
      ReDim Positions(LBound(Data) To UBound(Data), 1 To 1)
      For X = LBound(Uniques) To UBound(Uniques)
        For Z = LBound(Data) To UBound(Data)
          If Uniques(X, 1) = Data(Z, 1) Then Positions(Z, 1) = X - LBound(Uniques) + 1
        Next
      Next
      Application.ScreenUpdating = False
      Cells(1, DataColumn).Offset(, 1).Resize(LastDataRow) = Positions
      Application.ScreenUpdating = True
    End Sub
    Note 1: Unlike my previously posted code, this macro will work whether the Data values are constants or the result of formulas.

    Note 2: You should look at the three Const statements and make sure the values I assign to them matches your actual setup.
    Last edited by Rick Rothstein; 04-07-2012 at 07:47 PM.

  5. #5
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    14
    Hi,

    Actually Rick with the macro: MarkPositionNumbers2 cycle is faster.

    Precise figures are not all formulas
    I tested with Excel 2003 column "A" = 259 rows and column "G" = 19.900 lines.
    I get the following results: 1.500 seconds

    As with the previous MarkPositionNumbers approximately 5.050 seconds

  6. #6
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by PcMax View Post
    Actually Rick with the macro: MarkPositionNumbers2 cycle is faster.

    Precise figures are not all formulas
    I tested with Excel 2003 column "A" = 259 rows and column "G" = 19.900 lines.
    I get the following results: 1.500 seconds

    As with the previous MarkPositionNumbers approximately 5.050 seconds
    Thanks for perfoming your tests! Yes, given the simple actions required of the macro, I kind of figured the second one I posted would be faster than the first one. That percentage time difference (more than 3 times quicker) may not hold when you expand the data to the full amount you indicated was possible. The reason is the loop in the first macro only interates as many times as there are items in the unique list, but it physically interacts with the worksheet containing the data column, once per item... this direct interaction tends to be slow, but remember, we are only doing the interaction once per unique item. The second macro, on the other hand, gains it speed by doing almost all its work totally in memory, interacting only three times with the worksheet... twice to read in the values in the unique and data columns and a third time to blast the calculated data back out to the worksheet. I know that sounds like it should always be much faster to do, but the second macro does far more loop iterations than the first macro... it iterates more times by a multiplicative factor equal to the number of items in the data column. So, for you ulitmate limits, the first macro iterates 20 thousand times whereas the second one would iterate four billion times! It is hard to judge if the constant interaction with the worksheet for the first one would still eat up enough time to overcome the huge number of extra iterations being performed wholly in memory by the second macro. I think it would so I expect the second macro to still be faster, but I don't know that for a fact.

  7. #7
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi,

    Give it a try

    Code:
    Sub kTest()
        
        Dim Data, i As Long, Pos(), UnqList
        Dim r   As Long, dic As Object
        
        r = Range("a" & Rows.Count).End(xlUp).Row
        UnqList = Range("a2:a" & r)         'Unique List
        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(UnqList, 1)
            dic.Item(UnqList(i, 1)) = i
        Next
        
        For i = 1 To UBound(Data, 1)
            Pos(i, 1) = dic.Item(Data(i, 1))
        Next
        
        Range("h2").Resize(UBound(Pos, 1)) = Pos
        
    End Sub
    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)

  8. #8
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    14
    Hi,

    Performed a test with the macro Sub kTest.
    I get the following results: 0.110 seconds

    Remarkably faster, in line with the timing of a sort "sort" the same range of three columns

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://eileenslounge.com/viewtopic.php?p=318868#p318868
    https://eileenslounge.com/viewtopic.php?p=318311#p318311
    https://eileenslounge.com/viewtopic.php?p=318302#p318302
    https://eileenslounge.com/viewtopic.php?p=317704#p317704
    https://eileenslounge.com/viewtopic.php?p=317704#p317704
    https://eileenslounge.com/viewtopic.php?p=317857#p317857
    https://eileenslounge.com/viewtopic.php?p=317541#p317541
    https://eileenslounge.com/viewtopic.php?p=317520#p317520
    https://eileenslounge.com/viewtopic.php?p=317510#p317510
    https://eileenslounge.com/viewtopic.php?p=317547#p317547
    https://eileenslounge.com/viewtopic.php?p=317573#p317573
    https://eileenslounge.com/viewtopic.php?p=317574#p317574
    https://eileenslounge.com/viewtopic.php?p=317582#p317582
    https://eileenslounge.com/viewtopic.php?p=317583#p317583
    https://eileenslounge.com/viewtopic.php?p=317605#p317605
    https://eileenslounge.com/viewtopic.php?p=316935#p316935
    https://eileenslounge.com/viewtopic.php?p=317030#p317030
    https://eileenslounge.com/viewtopic.php?p=317030#p317030
    https://eileenslounge.com/viewtopic.php?p=317014#p317014
    https://eileenslounge.com/viewtopic.php?p=316940#p316940
    https://eileenslounge.com/viewtopic.php?p=316927#p316927
    https://eileenslounge.com/viewtopic.php?p=316875#p316875
    https://eileenslounge.com/viewtopic.php?p=316704#p316704
    https://eileenslounge.com/viewtopic.php?p=316412#p316412
    https://eileenslounge.com/viewtopic.php?p=316412#p316412
    https://eileenslounge.com/viewtopic.php?p=316254#p316254
    https://eileenslounge.com/viewtopic.php?p=316046#p316046
    https://eileenslounge.com/viewtopic.php?p=317050&sid=d7e077e50e904a138c794e1 f2115da95#p317050
    https://www.youtube.com/@alanelston2330
    https://www.youtube.com/watch?v=yXaYszT11CA&lc=UgxEjo0Di9-9cnl8UnZ4AaABAg.9XYLEH1OwDIA35HNIei0z-
    https://eileenslounge.com/viewtopic.php?p=316154#p316154
    https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
    https://teylyn.com/2017/03/21/dollarsigns/#comment-191
    https://eileenslounge.com/viewtopic.php?p=317050#p317050
    https://eileenslounge.com/viewtopic.php?f=27&t=40953&p=316854#p316854
    https://www.eileenslounge.com/viewtopic.php?v=27&t=40953&p=316875#p316875
    https://eileenslounge.com/viewtopic.php?p=316057#p316057
    https://eileenslounge.com/viewtopic.php?p=315915#p315915
    https://eileenslounge.com/viewtopic.php?p=316705#p316705
    https://eileenslounge.com/viewtopic.php?p=316704#p316704
    https://eileenslounge.com/viewtopic.php?p=176255#p176255
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 07-27-2024 at 01:45 PM.

  9. #9
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by PcMax View Post
    Hi,

    Performed a test with the macro Sub kTest.
    I get the following results: 0.110 seconds

    Remarkably faster, in line with the timing of a sort "sort" the same range of three columns
    I liked Admin's use of the Dictionary to cut down on the number of loops from the method I used. Just wondering if using a Collection might yield good results (possibly not because of the need to convert your unique numbers to text in order to use them as Keys for the Collection). Can you test this out to see what kind of execution time it yields for the database you ran the other code against?

    Code:
    Sub MarkPositionNumbers3()
        
        Dim Data As Variant, UnqList As Variant, Pos() As Variant
        Dim X As Long, Coll As New Collection
        
        UnqList = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
        Data = Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
        ReDim Pos(1 To UBound(Data, 1), 1 To 1)
        
        For X = 1 To UBound(UnqList)
            Coll.Add X, CStr(UnqList(X, 1))
        Next
        
        On Error Resume Next
        For X = 1 To UBound(Data)
            If Len(Data(X, 1)) Then Pos(X, 1) = Coll(CStr(Data(X, 1)))
        Next
        
        Range("H2").Resize(UBound(Pos, 1)) = Pos
        
    End Sub

  10. #10
    Senior Member
    Join Date
    Oct 2011
    Posts
    135
    Rep Power
    14
    Hi,

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

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
  •