Макрос для сортировки листов книги 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

23672 просмотра

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Слава, 5 Июн 2013 - 01:44.#1

Большое пребольшое спасибо - цены Вам нет!! Молодцы

Игорь (администратор сайта), 18 Апр 2013 - 18:05.#2

Антон, а что мешает выполнить эти действия вручную, включив при этом запись макросов?

Получите готовый макрос из 4 строк:

Sub ПечатьЛистовВЗаданномПорядке()
    Worksheets(1).PrintOut From:=1, To:=1, Copies:=1
    Worksheets(2).PrintOut From:=1, To:=1, Copies:=1
    Worksheets(1).PrintOut From:=2, To:=2, Copies:=1
    Worksheets(2).PrintOut From:=2, To:=2, Copies:=1
End Sub

Если листов много, и страниц на каждом листе тоже немало, — можно сделать цикл по листам,
взяв за основу предложенный выше макрос.

И ещё: в настройках печати Excel, есть опция «разобрать по копиям».
Возможно, она вам тоже пригодится.

Антон, 18 Апр 2013 - 16:42.#3

Подскажите, пожалуйста, как вывести на печать листы в постраничном порядке с каждого листа. Т.е. у меня несколько листов в файле, мне хотелось бы, чтобы принтер печатал в таком порядке: первая страница с первого листа, второя страница со второго листа, потом 2 страница с первого листа, 2 страница со второго листа и т.д..
Спасибо!

Гость, 17 Окт 2011 - 00:05.#4

Alex super, прога работает

Alex_ST, 12 Окт 2011 - 10:46.#5

Что-то сложновато...
Так, ИМХО, проще:

Private Sub СОРТИРОВАТЬ_ЛИСТЫ()   ' сортировка листов в активной книге (не сортирует скрытые листы)
   Dim i%, j%
   With ActiveWorkbook
      For i = 1 To .Sheets.Count - 1
         For j = i + 1 To .Sheets.Count
            If UCase(.Sheets(i).Name) > UCase(.Sheets(j).Name) Then .Sheets(j).Move Before:=.Sheets(i)
         Next j
      Next i
   End With
End Sub

Или так:

Sub СОРТИРОВАТЬ_ВСЕ_ЛИСТЫ()   ' сортировка листов в активной книге (сортирует даже скрытые листы)
   Application.ScreenUpdating = False: Application.EnableEvents = False
   Dim iSht As Worksheet, oDict As Object, i%, j%
   Set oDict = CreateObject("Scripting.Dictionary")
   For Each iSht In ActiveWorkbook.Sheets   ' запомнить состояние видимости каждого из листов и сделать все видимыми
      oDict.Item(iSht.Name) = iSht.Visible: iSht.Visible = True
   Next
   With ActiveWorkbook   ' сортировка видимых листов
      For i = 1 To .Sheets.Count - 1
         For j = i + 1 To .Sheets.Count
            If UCase(.Sheets(i).Name) > UCase(.Sheets(j).Name) Then .Sheets(j).Move Before:=.Sheets(i)
         Next j
      Next i
   End With
   For Each iSht In ActiveWorkbook.Sheets   ' восстановить исходное состояние видимости каждого из листов
      iSht.Visible = oDict.Item(iSht.Name)
   Next
   Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

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

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL