Рабочий лист Новый лист — через макрос

Листинг 2.11.Создание нового листа

Sub NewSheet()

Worksheets.Add

End Sub

Блокировка использования контекстного меню

Листинг 2.12. Блокировка контекстного меню

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Static intCount As Integer ' Счетчик нажатий кнопки мыши

Dim x As Integer, y As Integer

' Блокировать обработку щелчка правой кнопкой мыши

Cancel = True

' Отображение текстового поля с количеством щелчков правой _

кнопкой мыши

x = Target.Left

y = Target.Top

intCount = intCount + 1

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _

x, y, 35, 20).TextFrame.Characters.Text = intCount

End Sub

Вставка колонтитула с именем книги, листа и текущей датой

Листинг 2.13.Вставка колонтитула

SubAddPageHeader()

Dim i As Integer

With ThisWorkbook

' Вставка колонтитулов на все листы рабочей книги

For i = 1 To .Worksheets.Count - 1

.Worksheets(i).PageSetup.LeftHeader = .FullName

.Worksheets(i).PageSetup.CenterHeader = Worksheets(i).Name

.Worksheets(i).PageSetup.RightHeader = Now()

Next

End With

End Sub

Проверка существования листа

Листинг 2.14. Проверка существования листа

Function dhSheetExist(strSheetName As String) As Boolean

Dim objSheet As Object

On Error GoTo HandleError ' При ошибке перейти на HandleError

' Пытаемся получить ссылку на заданный лист

objSheet=ActiveWorkbook.Sheets(strSheetName)

' Ошибки не возникло - лист существует

dhSheetExist = True

Exit Function

HandleError:

' При попытке получить доступ к листу с заданным именем _

возникла ошибка, значит, такого листа не существует

dhSheetExist=False

EndFunction

Проверка, защищен ли рабочий лист

Листинг 2.15.Проверка наличия защиты рабочего листа

SubIsSheetProtected()

' Проверка, установлена ли защита на содержимое листа

If Worksheets(1).ProtectContents Then

MsgBox "Защита листа включена"

Else

MsgBox"Защита листа не включена"

EndIf

EndSub

Сколько страниц на всех листах?

Листинг 2.16.Подсчет страниц

SubGetPrintPagesCount()

Dim wshtSheet As Worksheet

Dim intPagesCount As Integer

' Суммирование количества страниц, необходимых для печати всех _

листов книги

For Each wshtSheet In Worksheets

intPagesCount = intPagesCount + (wshtSheet.HPageBreaks.Count + 1) * _

(wshtSheet.VPageBreaks.Count + 1)

Next

MsgBox "Всего страниц: " & intPagesCount

EndSub

Автоматический пересчет данных таблицы при изменении ее значений

Листинг 2.17. Переформирование таблицы

Sub Worksheet_Change(ByVal Target As Range)

Dim rgData As Range

Dim cell As Range

Dim dblMax As Double, dblMin As Double, dblAverage As Double

' Получение контролируемого диапазона ячеек

Set rgData = Range("B2:B11")

' Проверка, не входит ли измененная ячейка в контролируемый _

диапазон

If Not (Application.Intersect(Target, rgData) Is Nothing) Then

If Application.WorksheetFunction.CountA(rgData) > 0 Then

' Изменена ячейка из контролируемого диапазона

' Заново рассчитываем минимальное, максимальное и среднее _

значения в контролируемом диапазоне ячеек

dblMin=Application.WorksheetFunction.Min(rgData)

dblMax = Application.WorksheetFunction.Max(rgData)

dblAverage = Application.WorksheetFunction.Average(rgData)

' Проверяем каждую ячейку из контролируемого диапазона _

и изменяем цвет шрифта ячеек с минимальным и максимальным _

значениями, а также помечаем желтым цветом ячейки _

со значениями больше среднего

ForEachcellInrgData

Ifcell.Value=dblMaxThen

' Ячейку с максимальным значением выделим красным цветом

cell.Font.Bold = True

cell.Font.Color = RGB(255, 0, 0)

ElseIf cell.Value = dblMin Then

' Ячейку с минимальным значением выделим синим цветом

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 255)

Else

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 0)

End If

Ifcell.Value>dblAverageThen

' Значение в ячейке больше среднего - выделим ее _

желтым цветом

cell.Interior.Color=RGB(255, 255, 0)

Else

cell.Interior.ColorIndex = xlNone

End If

Next

Else

rgData.Interior.ColorIndex = xlNone

End If

End If

End Sub