Sub SortSheets2()

Dim astrSheetNames() As String ' Массив для хранения имен

листов

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

' Если нет активной рабочей книги – закрыть процедуру

If ActiveWorkbook Is Nothing Then Exit Sub

' Проверка защищенности структуры рабочей книги

If ActiveWorkbook.ProtectStructure Then

' Сортировка листов защищенной рабочей книги невозможна

MsgBox "Структура книги " & ActiveWorkbook.Name & _

« защищена. Сортировка листов невозможна.», _

vbCritical

Exit Sub

End If

' Сохраняем ссылку на активный лист книги

Set objActiveSheet = ActiveSheet

' Отключение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

' Функция обновления экрана отключается

Application.ScreenUpdating = False

With ActiveWorkbook

' Cоздаем новый лист «Сортировка» (если он еще не создан)

On Error Resume Next

If .Sheets(«Сортировка») Is Nothing Then

.Sheets.Add.Name = «Сортировка»

End If

On Error GoTo 0

' Размещение данных на листе «Сортировка» (в столбец A)

intSheetCount = .Sheets.Count

For i = 1 To intSheetCount

.Sheets(«Сортировка»).Cells(i, 1) = .Sheets(i).Name

Next i

' Сортировка данных в ячейках листа «Сортировка» по содержимому _

столбца A

.Sheets(«Сортировка»).Range(«A1»).Sort _

Key1:=.Sheets(«Сортировка»).Range(«A1»), _

Order1:=xlAscending

' Заполнение массива имен отсортированными строками

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = .Sheets(«Сортировка»).Cells(i, 1)

Next i

' Перемещение листов

For i = 1 To intSheetCount

.Sheets(astrSheetNames(i)).Move .Sheets(i)

Next i

End With

' Переход на исходный рабочий лист

objActiveSheet.Activate

' Включаем обновление экрана

Application.ScreenUpdating = True

' Включение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub