Сортировка листов в текущей рабочей книге

Листинг 2.8. Сортировка листов

Sub SortSheets()

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

intSheetCount = ActiveWorkbook.Sheets.Count

' Заполнение массива astrSheetNames именами листов книги

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name

Next i

' Сортировка массива имен в порядке возрастания

Call Sort(astrSheetNames)

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

For i = 1 To intSheetCount

ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

ActiveWorkbook.Sheets(i)

Next i

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

objActiveSheet.Activate

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

Application.ScreenUpdating = True

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

Application.EnableCancelKey = xlInterrupt

End Sub

Sub Sort(astrNames() As String)

' Сортировка массива строк по алфавиту (в порядке возрастания)

Dim i As Integer, j As Integer

Dim strBuffer As String

Dim fBuffer As Boolean

For i = LBound(astrNames) To UBound(astrNames) - 1

For j = i + 1 To UBound(astrNames)

If astrNames(i) > astrNames(j) Then

' Меняем i-й и j-й элементы массива местами

strBuffer = astrNames(i)

astrNames(i) = astrNames(j)

astrNames(j) = strBuffer

End If

Next j

Next i

End Sub

Листинг 2.9. Список отсортированных листов

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