Speed up Loop VBA

**PcMax** · 04-07-2012, 04:18 PM

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

**Rasm** · 04-07-2012, 06:46 PM

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

**Rick Rothstein** · 04-07-2012, 07:23 PM

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.

**Rick Rothstein** · 04-07-2012, 07:43 PM

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.

**PcMax** · 04-07-2012, 09:19 PM

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

**Rick Rothstein** · 04-07-2012, 09:54 PM

Originally Posted by PcMax

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.

**Admin** · 04-08-2012, 10:25 AM

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

**PcMax** · 04-08-2012, 11:12 AM

**Rick Rothstein** · 04-08-2012, 12:10 PM

Originally Posted by PcMax

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