Сортировка в MS EXCEL

Sub SuperSort()
Dim wsh As Worksheet, wm As Worksheet, wt As Worksheet
Dim i As Long, j As Long, NumSortCol As Long
Dim c As Range

    Application.ScreenUpdating = False
   
    'Создаем лист Maket и на нем макет сортируемого дипазона
    Set wsh = ThisWorkbook.Worksheets("ШАБЛОН")
    Set wm = ThisWorkbook.Worksheets.Add
    wm.Name = "Maket"
    NumSortCol = 8 'Номер столбца на листе ШАБЛОН, по которому сортируем
    i = 4 'Стартовый номер строки на листе ШАБЛОН
    j = 1 'Стартовый номер строки на листе Maket
   
    While wsh.Cells(i, NumSortCol).Value <> ""
        wm.Cells(j, 1).Value = wsh.Cells(i, NumSortCol).Value
        wm.Cells(j, 2).Value = i
        wm.Cells(j, 3).Value = wsh.Cells(i, NumSortCol).MergeArea.Rows.Count
        j = j + 1
        i = i + wsh.Cells(i, NumSortCol).MergeArea.Rows.Count
    Wend
   
    wm.Range("A:C").Sort Key1:=wm.Range("A:A"), Order1:=xlAscending, Header:=xlNo
   
    'Создаем лист TempShablon и на нем отсортированный диапазон
    Set wt = ThisWorkbook.Worksheets.Add
    wt.Name = "TempShablon"
    i = 1 'Стартовый номер строки на листе TempShablon
    j = 1 'Стартовый номер строки на листе Maket
   
    While wm.Cells(j, 1).Value <> ""
        wsh.Range(wsh.Cells(wm.Cells(j, 2).Value, 1), _
                wsh.Cells(wm.Cells(j, 2).Value + _
                wm.Cells(j, 3).Value - 1, 1)).EntireRow.Copy _
                Destination:=wt.Cells(i, 1)
        wt.Cells(i, 1).Value = j 'Это перепроставление порядкового номера строки. Если надо, его можно убрать
        i = i + wm.Cells(j, 3).Value
        j = j + 1
    Wend
   
    'Копируем отсортированный диапазон на место старого. Удаляем временные листы
    wt.Range(wt.Cells(1, 1), wt.Cells(i - 1, 1)).EntireRow.Copy _
            Destination:=wsh.Range("A4") 'i - как раз в конце диапазона
    Application.DisplayAlerts = False
    wm.Delete
    wt.Delete
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
End Sub