Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 25 из 47

Скрытие нескольких столбцов

Sub HideCollumns()

Columns("E:F").Hidden = True

End Sub

Скрытие строки по имени ячейки

Sub HideCell()

Range("Секрет").EntireRow.Hidden = True

End Sub

Скрытие нескольких строк по адресам ячеек

Sub HideCell()

Range("B3:D4").EntireRow.Hidden = True

End Sub

Скрытие столбца по имени ячейки

Sub HideCell()

Range("Секрет").EntireColumn.Hidden = True

End Sub

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

Sub HideCell()

Range("C2:D5").EntireColumn.Hidden = True

End Sub

Мигание ячейки

Sub BlinkingCell()

Static intCalls As Integer ' Счетчик количества миганий

' Если ячейка мигала менее 10 раз, то изменим _

в очередной раз ее цвет

If intCalls < 10 Then

intCalls = intCalls + 1

' Определение, какой цвет необходимо установить

If Range("A1").Interior.Color <> RGB(255, 0, 0) Then

' Цвет ячейки не красный, так что теперь назначим _

именно красный цвет

Range("A1").Interior.Color = RGB(255, 0, 0)

Else

' Назначим ячейке зеленый цвет

Range("A1").Interior.Color = RGB(0, 255, 0)

End If

' Эту процедуру необходимо вызвать через 5 секунд

Application.OnTime Now + TimeValue("00:00:05"), "BlinkingCell"

Else

' Хватит мигать

Range("A1").Interior.ColorIndex = xlNone

intCalls = 0

End If

End Sub

Глава 4. Работа с примечаниями

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

Sub ShowComments()

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

Функция извлечения комментария

Function GetCommentText(rCommentCell As Range)

Dim strGotIt As String

On Error Resume Next

strGotIt = WorksheetFunction.Clean _

(rCommentCell.Comment.Text)

GetCommentText = strGotIt

On Error GoTo 0

End Function

вставить в модуль эксель

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

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

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

MsgBox strComments

Else

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

End If

End Sub

Перечень примечаний в отдельном списке_1

Sub ListOfComments()

Dim cell As Range

Dim rgCells As Range

Dim intRow As Integer

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

On Error Resume Next

Set rgCells = Selection.SpecialCells(xlComments)

If rgCells Is Nothing Then

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

Exit Sub

End If

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

For Each cell In rgCells

' Вывод примечаний в ячейку столбца "C"

intRow = intRow + 1

Cells(intRow, 3) = cell.Comment.Text

Next

End Sub

Перечень примечаний в отдельном списке_2

Sub ListOfComments1()

Dim cell As Range

Dim strFirstAddress As String

Dim intRow As Integer

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

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

If Not cell Is Nothing Then

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

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

strFirstAddress = cell.Address

Do

' Вывод текста в столбец "C"

intRow = intRow + 1

Cells(intRow, 3) = cell.Comment.Text

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

Set cell = Cells.FindNext(cell)

Loop While Not cell Is Nothing And _

cell.Address <> strFirstAddress

End If

End Sub