Sub SortSheets()

    ' сортировка листов книги по алфавиту

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

    Dim intSheetCount As Integer, i As Integer, objActiveSheet As Object

    If ActiveWorkbook Is Nothing Then Exit Sub

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

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

     & " защищена. Сортировка листов невозможна.", vbCritical: Exit Sub

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

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

    Application.ScreenUpdating = False

    intSheetCount = ActiveWorkbook.Sheets.count

    ReDim astrSheetNames(1 To intSheetCount)    ' Заполнение массива astrSheetNames именами листов книги

    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

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

End Sub

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

    Dim i As Integer, j As Integer

    Dim strBuffer As String, 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

• 16945 просмотро