Четверг, Сентябрь 24, 2020

Сортировка листов

Sub SortSheets()
'Эта процедура сортирует листы
'активной рабочей книги в порядке возрастания.
  Dim SheetNames() As String
  Dim i As Long, SheetCount As Long
  Dim OldActiveSheet As Object
 
'Нет активной рабочей книги
  If ActiveWorkbook Is Nothing Then Exit Sub
 
'Проверка защищенной структуры рабочей книги
  If ActiveWorkbook.ProtectStructure Then
     MsgBox ActiveWorkbook.Name & " защищена.", _
        vbCritical, "Листы не могут быть отсортированы."
     Exit Sub
  End If
'Прверка пользователя
  If MsgBox("Сортировать листы в активной рабочей книге?", _
     vbQuestion + vbYesNo) <> vbYes Then Exit Sub
'Отключение комбинации клавиш <Ctrl+Break>
  Application.EnableCancelKey = xlDisabled
'Получение количества листов
  SheetCount = ActiveWorkbook.Sheets.Count
'Изменение размерности массива
  ReDim SheetNames(1 To SheetCount)
'Сохранение ссылки на активный лист
  Set OldActiveSheet = ActiveSheet
'Заполнение массива названиями листов
  For i = 1 To SheetCount
     SheetNames(i) = ActiveWorkbook.Sheets(i).Name
  Next i
'Сортировка массива в порядке возрастания
  Call BubbleSort(SheetNames)
'Отключение обновления экрана
  Application.ScreenUpdating = False
'Перемещение листов
  For i = 1 To SheetCount
     ActiveWorkbook.Sheets(SheetNames(i)).Move _
     before:=ActiveWorkbook.Sheets(i)
  Next i
'Повторная активация исходного активного листа
  OldActiveSheet.Active
End Sub


Sub BubbleSort(List() As String)
   Dim First As Long, Last As Long
   Dim i As Long, j As Long
   Dim temp As String
   First = LBound(List)
   Last = UBound(List)
   For i = First To Last - 1
      For j = i + 1 To Last
         If List(i) > List(j) Then
            temp = List(j)
            List(j) = List(i)
            List(i) = temp
        End If
      Next j
   Next i
End Sub


Back to Top