Option Base 1

Sub Pathfinder()
Const Bg& = 50, Ed& = 2000, Sp& = 50  'первое значение шага, последнее значение шага, шаг
Dim arr()
Dim arrItog()
Dim dic As Object
Dim dicItog As Object
Dim I&, J&, N&, ii&
Dim iKey, iTmp, iVr
Dim tm As Single

tm = Timer
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Условия")
  arr = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With

Set dic = CreateObject("Scripting.Dictionary")
Set dicItog = CreateObject("Scripting.Dictionary")

ReDim arrItog(1 To UBound(arr, 1), 1 To Int(Ed / Sp))
ReDim iTmp(1 To 1)

For N = Bg To Ed Step Sp
  For I = LBound(arr, 1) To UBound(arr, 1): iVr = dic(arr(I, 1)): Next
  For I = LBound(arr, 1) To UBound(arr, 1)
    iKey = arr(I, 1)
    If dic.Exists(iKey + N) Then
      J = 1
      For ii = I To UBound(arr, 1)
        If dic.Exists(iKey + N * J) Then
          dic.Remove (iKey + N * J)
          J = J + 1
        End If
      Next
      J = J - 1
      iTmp(UBound(iTmp)) = iKey & " [" & J & "]"
      ReDim Preserve iTmp(UBound(iTmp) + 1)
    End If
  Next
  dicItog.Add N, iTmp
  ReDim iTmp(1 To 1)
Next
N = 0: J = 0
For Each iKey In dicItog.Keys
  J = J + 1
  iTmp = dicItog(iKey)
  For I = LBound(iTmp) To UBound(iTmp)
    N = N + 1
    arrItog(N, J) = iTmp(I)
  Next
  N = 0
Next
With Worksheets("МАКРОС")
  .UsedRange.Value = Empty
  .Range("A1").Resize(, dicItog.Count) = dicItog.Keys
  .Range("A2").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
  .Activate
End With
Application.ScreenUpdating = True
MsgBox "Done!" & vbCrLf & Round((Timer - tm) * 1000, 0) & " мсек.", vbOKOnly
End Sub