VBA: Optimizar el doble loop FOR...NEXT.

Es de todos conocidos que muchas veces, aunque no queramos, no nos queda más remedio que emplear la instrucción FOR...NEXT para recorrer o 'barrer' listados o rangos de nuestras hojas de cálculo; y peor aún cuando tenemos que anidar un bucle dentro de otro, aparecen nuestras peores pesadillas: los dobles bucles (doble loop). Es aquí cuando nuestros procedimientos se ralentizan hasta términos insopechados, incluso llegando al bloqueo de nuestro equipo.
Lo que se busca con estos dobles bucles es verificar alguna condición anidada. Por ejemplo, en el ejercicio que planteo, trabajamos sobre un listado de 1.000 elementos, valores repetidos entre 1 y 50. Pretendemos obtener un primer listado de esos valores repetidos (en este caso es muy simple, son valores del 1 al 50), para luego recorrer nuevamente el listado de 1.000 elementos buscando coincidencias o cualquier otra cosa.

Es lógico, por tanto, que intentemos optimizar, en la medida de lo posible estas acciones dobles. La idea es lograr limitar el segundo recorrido únicamente a las celdas de nuestro listado a estudio, limitando por tanto el tiempo destinado a ese 'barrido' de datos.
En un doble bucle sin restricciones, lo que ocurre realmente es que recorremos todos y cada uno de los elementos del listado una y otra vez, siguiendo las indicaciones.

Vamos a ver a continuación dos procedimientos similares, un primer con un doble bucle al uso, mediante el cual recorremos una y otra vez la totalidad de los elementos, tantas veces como registros únicos hallamos contado.
Mientras que en el segundo procedimiento, restringiremos el recorrido únicamente por los elementos coincidentes (que son los que nos interesan), para lo cual emplearemos la función de VBA FIND.

Insertamos el siguiente código VBA en un módulo del Explorador de proyectos VBA para el doble bucle largo:

Sub LoopTotal()
Dim celda As Object, ID As Object
Dim i As Integer
Dim mirng As String

inicio = Timer
Set unicos = New Collection
'loop en todas las celdas y agregarlas a la coleccion
For Each celda In Sheets("Pfr").Range("IDE")
    On Error Resume Next
    unicos.Add celda.Value, CStr(celda.Value)
    On Error GoTo 0
Next celda

Application.ScreenUpdating = False
'escribir los datos en la Hoja de cálculo
For i = 1 To unicos.Count
    'con un loop general (requiere mucho tiempo...)
    For Each ID In Sheets("Pfr").Range("IDE")
        'incrementamos el contador de operaciones realizadas
        x = x + 1
        'acción de búsqueda e identificación (en este ejemplo no hace nada).
        If ID.Value = unicos(i) Then
        mirng = ID.Offset(0, 2).Address
        End If
    Next ID
Next i
Application.ScreenUpdating = True

Final = Timer
Sheets("Pfr").Range("D2").Value = Final - inicio
Sheets("Pfr").Range("D3").Value = x
End Sub

Insertamos el siguiente código VBA en un módulo del Explorador de proyectos VBA para el doble bucle restringido y más óptimo:

Sub LoopControlado()
Dim celda As Object
Dim i As Integer

inicio = Timer
Set unicos = New Collection
'loop en todas las celdas y agregarlas a la coleccion
For Each celda In Sheets("Pfr").Range("IDE")
    On Error Resume Next
    unicos.Add celda.Value, CStr(celda.Value)
    On Error GoTo 0
Next celda

Application.ScreenUpdating = False
'escribir los datos en la Hoja de cálculo
For i = 1 To unicos.Count
    'con un loop controlado sobre un rango más reducido
    Dim iLoop As Integer
    Dim j As Integer
    
    'definimos variables, para iniciar la búsqeuda FIND
    Set rNa = Sheets("Pfr").Range("A2")
    'y contamos los elementos coincidentes para el valor buscado
    iLoop = WorksheetFunction.CountIf(Sheets("Pfr").Columns(1), CStr(unicos(i)))
    'iniciamos la búsqueda restringida únicamente a los valores coincidentes
    For j = 1 To iLoop
        'acción de búsqueda e identificación (en este ejemplo no hace nada).
        Set rNa = Sheets("Pfr").Columns(1).Find(What:=CStr(unicos(i)), After:=Sheets("Pfr").Range(rNa.Address), _
         LookIn:=xlValues, LookAt:=xlWhole, _
         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=True)
        'incrementamos el contador de operaciones realizadas
        x = x + 1
    Next j
Next i

Application.ScreenUpdating = True
Final = Timer
Sheets("Pfr").Range("E2").Value = Final - inicio
Sheets("Pfr").Range("E3").Value = x
End Sub

La diferencia fundamental entre uno y otro radica en que el segundo Loop, en el caso óptimo recorre únicamente los valores repetidos, miestras que en el caso Total, pasa por todos los registros una y otra vez.

Vemos en la imagen el listado de 1.000 elementos repetidos (de 1 a 50), y cómo hemos asociado cada procedimiento a un Botón. En las celdas D2:E3 mediante los procedimientos reflejaremos los tiempos empleados así como el número de operaciones realizadas:

Podemos observar el ahorro de tiempo y sobre todo operaciones realizadas de uno frente a otro procedimiento... y esto es sólo para mil registros, imaginemos si trabajaramos sobre 10.000.