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

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

Sub Workbook_BeforeClose(Cancel As Boolean)

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

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

команду

Cancel=True

EndIf

EndSub

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

Листинг 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.Сортировка листов

SubSortSheets()

DimastrSheetNames()AsString' Массив для хранения имен листов

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

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

SetobjActiveSheet=ActiveSheet

' Отключение сочетания клавиш Ctrl+PauseBreak

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

' Сортировка массива имен в порядке возрастания

CallSort(astrSheetNames)

' Перемещение листов книги

For i = 1 To intSheetCount

ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

ActiveWorkbook.Sheets(i)

Next i

' Переход на исходный рабочий лист

objActiveSheet.Activate

' Включение обновления экрана

Application.ScreenUpdating=True

' Включение сочетания клавиш Ctrl+PauseBreak

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. Список отсортированных листов

SubSortSheets2()

DimastrSheetNames()AsString' Массив для хранения имен листов

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

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

SetobjActiveSheet=ActiveSheet

' Отключение сочетания клавиш Ctrl+PauseBreak

Application.EnableCancelKey=xlDisabled

' Функция обновления экрана отключается

Application.ScreenUpdating=False

WithActiveWorkbook

' Cоздаем новый лист "Сортировка" (если он еще не создан)

On Error Resume Next

If .Sheets("Сортировка") Is Nothing Then

.Sheets.Add.Name = "Сортировка"

End If

OnErrorGoTo0

' Размещение данных на листе "Сортировка" (в столбец "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+PauseBreak

Application.EnableCancelKey=xlInterrupt

EndSub