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

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

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

Sub ListOfCommentsToFile()

Dim rgCells As Range ' Ячейки с примечаниями

Dim intDefListCount As Integer ' Используется для временного _

хранения количества листов в книге по умолчанию

Dim strSheet As String ' Имя анализируемого листа

Dim strWorkBook As String ' Имя книги с анализируемым листом

Dim intRow As Integer

Dim cell As Range

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

On Error Resume Next

Set rgCells = ActiveSheet.Cells.SpecialCells(xlComments)

On Error GoTo 0

' Если примечаний нет, то можно не продолжать

If rgCells Is Nothing Then

MsgBox "Текущая рабочая книга не содержит примечаний.", _

vbInformation

Exit Sub

End If

' Сохранение имен анализируемого листа и книги

strSheet = ActiveSheet.Name

strWorkBook = ActiveWorkbook.Name

' Создание отдельной книги с одним листом _

для отображения результатов

intDefListCount = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1

Workbooks.Add

Application.SheetsInNewWorkbook = intDefListCount

ActiveWorkbook.Windows(1).Caption = "Comments for " & strSheet & _

" in " & strWorkBook

' Создание списка примечаний

Cells(1, 1) = "Адрес"

Cells(1, 2) = "Содержимое"

Cells(1, 3) = "Комментарий"

Range(Cells(1, 1), Cells(1, 3)).Font.Bold = True

intRow = 2 ' Данные начинаются со второй строки

For Each cell In rgCells

Cells(intRow, 1) = cell.Address(rowabsolute:=False, _

columnabsolute:=False)

Cells(intRow, 2) = " " & cell.Formula

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

intRow = intRow + 1

Next

End Sub

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

Sub CountOfComments()

Dim intCommentCount As Integer

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

intCommentCount = ActiveSheet.Comments.Count

If intCommentCount = 0 Then

MsgBox "Текущая рабочая книга не содержит примечаний.", _

vbInformation

Else

MsgBox "В текущей рабочей книге содержится " & intCommentCount _

& " комментариев.", vbInformation

End If

End Sub

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

' Function IsCommentsPresent

' Возвращает TRUE, если на активном рабочем листе имеется хотя бы

' одна ячейка с комментарием, иначе возвращает FALSE

'

Public Function IsCommentsPresent() As Boolean

IsCommentsPresent = ( ActiveSheet.Comments.Count <> 0 )

End Function

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

Sub CountOfComment()

Dim intCommentCount As Integer

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

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

intCommentCount = ActiveSheet.Comments.Count

If intCommentCount = 0 Then

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

Else

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

End If

End Sub

Выделение ячеек с примечаниями

Sub SelectComments()

' Выделение всех ячеек с примечаниями

Cells.SpecialCells(xlCellTypeComments).Select

End Sub

Отображение всех примечаний

Sub ShowComments()

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

If Application.DisplayCommentIndicator = xlCommentAndIndicator Then

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Else

Application.DisplayCommentIndicator = xlCommentAndIndicator

End If

End Sub

Изменение цвета примечаний

Sub ChangeCommentColor()

' Автоматическое изменение цвета комментариев

Dim comment As comment

For Each comment In ActiveSheet.Comments

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

comment.Shape.Fill.ForeColor.SchemeColor = Int((80) * Rnd + 1)

comment.Shape.TextFrame.Characters.Font.ColorIndex = Int((56 _

) * Rnd + 1)

Next

End Sub

Добавление примечаний

Dim r As Range

Dim rwIndex As Integer

 

For rwIndex = 1 To 3

Set r = Worksheets("WombatBattingAverages").Cells(rwIndex, 2)

With r

If .Value >= 0.3 Then

.AddComment "All Star!"

End If

End With

Next rwIndex