Быстрое выделение ячеек, расположенных через интервал

Листинг 3.23.Выделение ячеек через интервал (вариант 1)

Sub IntervalCellSelect()

Dim intFirstRow As Integer ' Первая строка для выделения

Dim intLastRow As Integer ' Последняя строка для выделения

Dim rgCells As Range ' Объединение выделяемых ячеек

Dim intRow As Integer

intFirstRow = 3

intLastRow = 300

' Формирование объединения ячеек в столбце "B" от строки _

intFirstRow до строки intLastRow с шагом 3

For intRow = intFirstRow To intLastRow Step 3

If rgCells Is Nothing Then

' Первая ячейка в объединении

Set rgCells = Cells(intRow, 1)

Else

' Добавление очередной ячейки в объединение

Set rgCells = Union(rgCells, Cells(intRow, 1))

End If

Next

' Выделение всех ячеек в объединении

rgCells.Select

End Sub

Листинг 3.24. Выделение ячеек через интервал (вариант 2)

Sub IntervalCellSelect()

Dim intFirstRow As Integer ' Первая строка для выделения

Dim intLastRow As Integer ' Последняя строка для выделения

Dim rgCells As Range ' Объединение выделяемых ячеек

Dim cell As Range ' Текущая ячейка

Dim intRow As Integer

intFirstRow = 3

intLastRow = 300

' Формирование объединения ячеек в столбце "B" от строки _

intFirstRow до строки intLastRow с шагом 3

For intRow = intFirstRow To intLastRow Step 3

Set cell = Cells(intRow, 1)

Set rgCells = Union(cell, _

IIf(intRow = intFirstRow, cell, rgCells))

Next

' Выделение всех ячеек в объединении

rgCells.Select

End Sub

Листинг 3.25. Выделение нескольких диапазонов

SubSelectRange()

Range("D3:D10, A3:A10 , F3").Select

End Sub

Определение количества ячеек в диапазоне и суммы их значений

Листинг 3.26.Сумма данных диапазона

SubCalculateSum()

Dim i As Integer

Dim intSum As Integer

' Расчет суммы ячеек столбца "A" (с первой по пятую)

For i = 1 To 5

intSum = intSum + Cells(i, 1)

Next

MsgBox "Сумма ячеек: " & intSum

End Sub

Листинг 3.27.Сумма ячеек с числовыми значениями

Sub CalculateSum()

Dim i As Integer

DimintSumAsInteger

' Расчет суммы ячеек столбца "A" (с первой по пятую)

For i = 1 To 5

If IsNumeric(Cells(i, 1)) Then

intSum = intSum + Cells(i, 1)

End If

Next

MsgBox "Сумма ячеек: " & intSum

End Sub

Листинг 3.28.Подсчет количества ячеек

SubCountOfCells()

MsgBox (Range("A1:A20, D1:D20").Count)

End Sub

Подсчет именованных объектов

Листинг 3.29.Количество именованных объектов

SubCountNames()

DimintNamesCountAsInteger

' Получаем и отображаем количество имен в активной _

рабочей книге

intNamesCount=ActiveWorkbook.Names.Count

If intNamesCount = 0 Then

MsgBox "Имен нет"

Else

MsgBox "Имен: " & intNamesCount & " шт."

End If

End Sub

Листинг 3.30. Количество имен рабочей книги

SubCountNames()

DimintNamesCountAsInteger

' Получаем и отображаем количество имен на активном _

листе рабочей книги

intNamesCount = Names.Count

If intNamesCount = 0 Then

MsgBox "Имен нет"

Else

MsgBox "Имен: " & intNamesCount & " шт."

EndIf

EndSub

Быстрый поиск курсора

Листинг 3.31.Поиск активной ячейки

SubFindActiveCell()

' Выводим адрес активной ячейки

MsgBoxActiveCell.Address

EndSub

Поиск начала и окончания диапазона, содержащего данные

Листинг 3.32.Поиск данных

SubFindSheetData()

' Выводим диапазон используемых ячеек листа

MsgBox ActiveSheet.UsedRange.Address

End Sub

Листинг 3.33.Поиск начала данных

SubFindStartOfData()

WithActiveSheet

' Заносим текст в ячейку, являющуюся левой верхней _

ячейкой используемого диапазона

.Cells(.UsedRange.Row, .UsedRange.Column).Value= _

"Начало данных"

End With

End Sub

Трюки с примечаниями

Подсчет примечаний

Листинг 3.34.Подсчет примечаний

Sub CountOfComment()

Dim intCommentCount As Integer

' Получение и отображение количества примечаний _

на текущем листе

intCommentCount = ActiveSheet.Comments.Count

If intCommentCount = 0 Then

MsgBox "Примечаний нет"

Else

MsgBox "Примечаний: " & intCommentCount & " шт."

End If

End Sub

Вывод на экран всех примечаний рабочего листа

Листинг 3.35.Список примечаний

SubShowComments()

Dim cell As Range

Dim rgCells As Range

' Получение всех ячеек с примечаниями

Set rgCells = Selection.SpecialCells(xlComments)

If rgCells Is Nothing Then

' Примечаний нет

Exit Sub

End If

' Проходим по всем ячейкам диапазона

For Each cell In rgCells

' Вывод примечаний в соседнюю ячейку

cell.Next.Value = cell.Comment.Text

Next

End Sub

Листинг 3.36.Список примечаний защищенных листов

Sub ShowComments1()

Dim cell As Range

Dim strFirstAddress As String

Dim strComments As String

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

Set cell = Selection.Find("*", LookIn:=xlComments)

If Not cell Is Nothing Then

' Сохранение адреса первой найденной ячейки _

(для предотвращения зацикливания поиска)

strFirstAddress = cell.Address

Do

' Добавление текста примечания в выходную строку

strComments = strComments & "Комментарий: " & _

cell.Comment.Text & Chr(13)

' Продолжение поиска

Set cell = Selection.FindNext(cell)

Loop While Not cell Is Nothing And _

cell.Address <> strFirstAddress

End If

If strComments <> "" Then

' Отображение окна с текстом примечаний

MsgBoxstrComments

Else

MsgBox"В выделенной ячейке/ячейках комментариев нет"

EndIf

EndSub