Форум по VBA и MS Office

Sub Main()

    Dim shAct As Worksheet, shTemp As Worksheet
    Dim rngAct As Range, rngTemp As Range, arr(), dicRangs As Object
    Dim lng_rang As Long, lr As Long, i As Long
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    '2. Vba-именование активного листа.
    Set shAct = ActiveSheet
   
    '3. Vba-именование фрагмента на активном листе, в котором находятся данные.
    lr = shAct.Columns("B").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    Set rngAct = shAct.Range("A1:B" & lr)
   
    '4. Создание временного файла и vba-именование первого листа.
    Set shTemp = Workbooks.Add.Worksheets(1)
   
    '5. Vba-именование фрагмента на временном листе, где будут данные.
    Set rngTemp = shTemp.Range("A1").Resize(rngAct.Rows.Count, 2)
   
    '6. Копирование данных из активного листа на временный.
    rngAct.Columns(2).Copy
    rngTemp.Columns(2).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
   
    '7. Сортировка.
    shTemp.Sort.SortFields.Add Key:=rngTemp.Columns(2), Order:=xlAscending
    With shTemp.Sort
        .SetRange rngTemp.Columns(2)
        .Header = xlNo
        .Orientation = xlTopToBottom
        .Apply
    End With
   
    '8. Копирование данных в vba-массив, чтобы ускорить.
    arr() = rngTemp.Value
   
    '9. Удаление временного файла.
    shTemp.Parent.Close SaveChanges:=False
   
    '10. Вставка в массив в столбец слева рангов.
    For i = 1 To UBound(arr, 1) Step 1
        If arr(i, 2) <> 0 Then
            ' Если это первое число.
            If lng_rang = 0 Then
                lng_rang = lng_rang + 1
                arr(i, 1) = lng_rang
            Else
                ' Сравнение с вышестоящим.
                If arr(i, 2) = arr(i - 1, 2) Then
                    arr(i, 1) = lng_rang
                Else
                    lng_rang = lng_rang + 1
                    arr(i, 1) = lng_rang
                End If
            End If
        End If
    Next i
   
    '11. Копирование данных из массива в словарь.
    Set dicRangs = CreateObject(Class:="Scripting.Dictionary")
    For i = 1 To UBound(arr, 1) Step 1
        If dicRangs.Exists(Key:=arr(i, 2)) = False Then
            dicRangs.Add Key:=arr(i, 2), Item:=arr(i, 1)
        End If
    Next i
   
    '12. Копирование данных из эксель в массив для ускорения.
    arr() = rngAct.Value
   
    '13. Вставка рангов.
    For i = 1 To UBound(arr, 1) Step 1
        If dicRangs.Exists(Key:=arr(i, 2)) = True Then
            rngAct.Cells(i, 1).Value = dicRangs.Item(Key:=arr(i, 2))
        End If
    Next i
   
    '14. Включение монитора.
    Application.ScreenUpdating = True
   
    '15. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub