Готовые макросы в vba excel, Миронов Глава Макросы 9
![]()
|
Перечень примечаний в отдельном списке_3Sub 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 Подсчет количества примечаний_1Sub 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 Подсчет примечаний_3Sub 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 |