Speed up Loop VBA

[PcMax]

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.


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]

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.




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]

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...


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]

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.


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]

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]

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]

Hi,

Give it a try


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]

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

[Rick Rothstein]

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?


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

[PcMax]

Hi,

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

[Rick Rothstein]

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.:rolleyes:

[PcMax]

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:


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:

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]

Hi,


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]

Hi,

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

Range("M2").Resize(UBound(dic.Count, 1)) = Application.Transpose(dic.items)
Why report an error like: runtime - 13

I replaced it with:

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

The routine works fine

[Admin]

Hi

My bad :(

replace


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

with


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

[PcMax]

Hi,

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