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

Быстрое удаление из рабочей книги ненужных имен

Закрытие рабочей книги только при выполнении условия

Установка и снятие защиты рабочей книги

Создание книги с одним листом

Листинг 2.3. Книга с одним листом

Sub NewOneSheetBook()

Workbooks.Add xlWBATWorksheet

End Sub

Листинг 2.4. Защита рабочей книги

Sub Worksheet_BeforeRightClick(ByVal Target As Range, _

Cancel As Boolean)

If Target.Address = "$D$2" Then

' Установка защиты рабочей книги (с паролем "123", _

включенной защитой структуры книги и защитой расположения _

окон)

ThisWorkbook.Protect "123", True, True

' Указание не обрабатывать нажатие кнопки мыши _

в этой ячейке

Cancel = True

ElseIf Target.Address = "$E$5" Then

' Снятие защиты с книги (необходимо указать ранее установленный _

пароль)

ThisWorkbook.Unprotect "123"

Cancel = True

End If

End Sub

Листинг 2.5. Запрет печати книги

Sub Workbook_BeforePrint(Cancel As Boolean)

' Установка флага в True заставляет Exсel игнорировать команду _

отправки книги на печать

Cancel = True

End Sub

Листинг 2.6. Условное закрытие книги

Sub Workbook_BeforeClose(Cancel As Boolean)

If Range("A1").Value <> "Можно закрывать" Then

' Условие закрытия не выполнено. Укажем Exсel игнорировать _

команду

Cancel = True

End If

End Sub

Листинг 2.7. Удаление ненужных имен

Sub EraseNames()

Dim nmName As Name

Dim strMessage As String

' Проверка наличия в книге определенных имен

If ThisWorkbook.Names.Count = 0 Then

' В книге нет определенных имен

MsgBox "Имена не определены"

Exit Sub

End If

' Просмотр всей коллекции определенных имен и удаление тех, _

которые пользователю не нужны

For Each nmName In ThisWorkbook.Names

With nmName

' Спрашиваем пользователя о необходимости удалить _

найденное имя

strMessage = "Удалить имя " &.Name & "? " & vbCr & _

"относящееся к " &.RefersTo

If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then

' Имя можно удалить

.Delete

End If

End With

Next

End Sub

Листинг 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

Дата добавления: 2015-06-25