Speed up Loop VBA

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