MyTetra Share
Делитесь знаниями!
Макрос для сортировки листов книги Excel по алфавиту
16.03.2019
23:43
Текстовые метки: Sheets,Sort
Раздел: !Закладки - VBA - Excell

Макрос для сортировки листов книги Excel по алфавиту

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 просмотро
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования