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

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

 

Добавление примечаний в диапазон по условию

Sub CreateComments()

Dim cell As Range

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

ко всем ячейкам, содержащим слово "Выручка"

 For Each cell In Range("B1:B100")

If cell.Value Like "*Выручка*" Then

    cell.ClearComments

    cell.AddComment "Неучтенная наличка"

End If

Next

End Sub

Перенос комментария в ячейку и обратно

 

Sub Комментарий_в_ячейку_в_диапазоне()

'переносит комментарий в ячейку

Dim i As Long

Dim c As Range, cc As Range

Dim iCommment As Comments

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Set cc = Selection

'если выделили 1 ячейку, то выход

If cc.Rows.Count = 1 And cc.Columns.Count = 1 Then

MsgBox "Выделено слишком мало ячеек!",, "Ошибка"

End

End If

Set cc = Selection.SpecialCells(xlCellTypeVisible)

For Each c In cc

If Not c.Comment Is Nothing Then

c.Value = c.Comment.Text

'c.ClearComments 'если надо удалить комментарий

i = i + 1

End If

End If

Next

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

MsgBox "Перенесено " & i & " комментариев!"

Exit Sub

End Sub

 

Перенос значений из ячейки в комментарий_1

 

Sub Добавить_комментарий_в_диапазоне()

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

Dim c As Range, cc As Range

Dim i As Long

On Error GoTo ErrorHandler

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Set cc = Selection

'если выделили 1 ячейку, то выход

If cc.Rows.Count = 1 And cc.Columns.Count = 1 Then

MsgBox "Выделено слишком мало ячеек!",, "Ошибка"

End

End If

Set cc = Selection.SpecialCells(xlCellTypeVisible)

For Each c In cc

If c.Value <> Empty Then

c.AddComment CStr(c.Value)

i = i + 1

End If

Next

MsgBox "Добавлено " & i & " комментарий!"

Exit Sub

End Sub

Перенос значений из ячейки в комментарий_2

 

Sub Comment_in_Cell()

Dim c As Range

Dim r As Range

If ActiveSheet.Comments.Count = 0 Then MsgBox "Без комментариев!": Exit Sub

Set sh = ActiveSheet

Set shnew = Sheets.Add

sh.Select

Set r = Range(Cells(1, 1), Cells(Cells.Find("*", [A1], xlComments,, xlByRows, _

xlPrevious).Row, Cells.Find("*", [A1], xlComments,, xlColumns, _

xlPrevious).Column))

For Each c In r

If Not c.Comment Is Nothing Then

shnew.Range(c.Address) = c.Comment.Text

End If

Next

End Sub

 

 

Глава. Пользовательские вкладки на ленте

 

Дополнение панели инструментов

Sub AddCustomCommandBar()

' Добавление кнопки на панель инструментов

With Application.CommandBars(3).Controls.Add(Type:=msoControlButton)

.FaceId = 42       ' Значок Word

.Caption = "Кнопка"

.OnAction = "Макрос"

End With

End Sub

Добавление кнопки на панель инструментов

Sub AddCustomButton()

' Добавление кнопки на панель инструментов

With Application.Toolbars(1).ToolbarButtons.Add(button:=222)

.Name = "Кнопка"

.OnAction = "Макрос"

End With

End Sub

Панель с одной кнопкой

Sub CreateCustomControlBar()

' Создание панели инструментов

With Application.CommandBars.Add(Name:="Панель", Temporary:=True)

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

With.Controls.Add(Type:=msoControlButton)

   .Style = msoButtonIconAndCaption

   .FaceId = 66

   .Caption = "Просто кнопка"

End With

' Покажем панель

.Visible = True

End With

End Sub

Панель с двумя кнопками

Sub CreateCustomControlBar()

' Создание панели инструментов

With Application.CommandBars.Add(Name:="Панель", Temporary:=True, _

Position:=msoBarLeft)

' Создание и настройка первой кнопки

With.Controls.Add(Type:=msoControlButton)

   .Style = msoButtonWrapCaption

   .Caption = "Просто кнопка"

End With

' Создание и настройка второй кнопки

With.Controls.Add(Type:=msoControlButton)

   .Style = msoButtonIconAndWrapCaption

   .Caption = "Кнопка"

   .FaceId = 225

End With

' Покажем панель

.Visible = True

End With

End Sub

Создание панели справа

Sub CreateCustomControlBar()

' Создание панели инструментов

With Application.CommandBars.Add(Name:="Правая панель", _

Temporary:=True)

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

With.Controls.Add(Type:=msoControlButton)

   .Style = msoButtonWrapCaption

   .Caption = "Кнопка"

End With

 

' Задание позиции - справа

.Position = msoBarRight

' Покажем панель

.Visible = True

End With

End Sub

Вызов предварительного просмотра

Sub Test()

 With Application.Workbooks.Item("Test.xls")

 Sheets("Test").PrintPreview

 End With

End Sub

 

Создание пользовательского меню (вариант 1)

Sub AddCustomMenu()

' Добавление меню

With Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

.Caption = "Архив"

  With.Controls

    ' Добавление и настройка первого пункта

    With.Add(Type:=msoControlButton)

      .FaceId = 280

      .Caption = "Просмотр"

      .OnAction = "Макрос1"

    End With

    ' Добавление вложенного меню

    With.Add(Type:=msoControlPopup)

      .Caption = "База данных"

       With.Controls

          ' Добавление и настройка первого пункта _

           вложенного меню

          With.Add(Type:=msoControlButton)

             .FaceId = 1643

            .Caption = "Поставщики"

            .OnAction = "Макрос2"

          End With

          ' Добавление и настройка второго пункта _

           вложенного меню

          With.Add(Type:=msoControlButton)

            .FaceId = 1000

            .Caption = "Покупатели"

            .OnAction = "Макрос3"

          End With

       End With

    End With

End With

End With

End Sub

Создание пользовательского меню (вариант 2)

Sub AddCustomMenu1()

' Добавление меню с названием "Архив" в часть меню, _

относящуюся к рабочей книге

With MenuBars("Worksheet").Menus.Add(Caption:="Архив")

' Добавление кнопки

.MenuItems.Add Caption:="Просмотр", OnAction:="Макрос1"

' Добавление подменю

With.MenuItems.AddMenu(Caption:="База данных")

    ' Добавление пунктов подменю

   .MenuItems.Add Caption:="Поставщики", OnAction:="Макрос2"

   .MenuItems.Add Caption:="Покупатели", OnAction:="Макрос3"

End With

End With

End Sub

Создание пользовательского меню (вариант 3)

Sub AddCustomMenu2()

' Добавление меню с названием "Архив" в часть меню, _

относящуюся к рабочей книге

With MenuBars("Worksheet").Menus.Add(Caption:="Архив")

' Добавление кнопки

.MenuItems.Add Caption:="Просмотр", OnAction:="Макрос1"

' Добавление подменю

With.MenuItems.AddMenu(Caption:="База данных")

    ' Добавление первого пункта подменю

    With.MenuItems.Add(Caption:="Поставщики")

       ' Настройка кнопки

      .OnAction = "Макрос2"

    End With

    ' Добавление второго пункта подменю

    With.MenuItems.Add(Caption:="Покупатели")

       ' Настройка кнопки

      .OnAction = "Макрос3"

    End With

End With

End With

End Sub

Создание пользовательского меню (вариант 4)

 

Sub Workbook_Open()

' Задание имени меню

strMenuName = "MyCommandBarName"

' Создание меню

CreateCustomMenu

End Sub

Создание пользовательского меню (вариант 5)

 

Sub Workbook_BeforeClose(Cancel As Boolean)

' Удаление меню перед закрытием книги

DeleteCustomMenu

End Sub

 

Public strMenuName As String ' Имя строки меню

Private cbrcBar As CommandBarControl

 

Sub CreateCustomMenu()

Dim cbrMenu As CommandBar

Dim cbrcMenu As CommandBarControl ' Выпадающее меню "Меню"

Dim cbrcSubMenu As CommandBarControl ' Выпадающее меню "Дополнительно"

 

' Если уже есть пользовательское меню, то оно удаляется

DeleteCustomMenu

 

' Создание меню вместо стандартного

Set cbrMenu = Application.CommandBars.Add(strMenuName, msoBarTop, _

True, True)

' Создание выпадающего меню с названием "Меню"

Set cbrcMenu = cbrMenu.Controls.Add(msoControlPopup,,,, True)

With cbrcMenu

.Caption = "&Меню"

End With

 

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "&Меню1"

.OnAction = "CallMenu1"

End With

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Меню2"

.OnAction = "CallMenu2"

End With

' Создание подменю первого уровня

Set cbrcSubMenu = cbrcMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "Подменю1"

.BeginGroup = True

End With

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Вкл/Выкл"

.OnAction = "MenuOnOff"

.Style = msoButtonIconAndCaption

.FaceId = 463

End With

' Создание пункта меню в подменю первого уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Подменю1"

.OnAction = "CallSubMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 2950

.State = msoButtonDown

End With

' Cоздание пункта меню в подменю первого уровня (его состояние _

изменяется посредством пункта "Вкл/Выкл"), для чего сохраним ссылку _

на созданный пункт меню

Set cbrcBar = cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

With cbrcBar

.Caption = "Подменю2"

.OnAction = "CallSubMenu2"

' Сначала меню деактивировано

.Enabled = False

End With

' Создание подменю второго уровня

Set cbrcSubMenu = cbrcSubMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "ПодчПодменю1"

.BeginGroup = True

End With

' Cоздание пункта меню в подменю второго уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "ПослМеню1"

.OnAction = "CallLastMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown

End With

' Cоздание пункта меню в подменю второго уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "ПослМеню2"

.OnAction = "CallLastMenu2"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = True

End With

 

' Отображение меню

cbrMenu.Visible = True

Set cbrcSubMenu = Nothing

Set cbrcMenu = Nothing

Set cbrMenu = Nothing

End Sub

 

Sub DeleteCustomMenu()

' Удаление строки меню

On Error Resume Next

Application.CommandBars(strMenuName).Delete

 On Error GoTo 0

End Sub

 

Sub CallMenu1()

' Обработка вызова Меню1

MsgBox "Приветствует меню 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallMenu2()

' Обработка вызова Меню2

MsgBox "Приветствует меню 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallSubMenu1()

' Обработка вызова Подменю1

MsgBox "Приветствует подменю 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallSubMenu2()

' Обработка вызова Подменю2

MsgBox "Приветствует подменю 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallLastMenu1()

' Обработка вызова Последнего меню1

MsgBox "Приветствует последнее меню 1!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallLastMenu2()

' Обработка вызова Последнего меню2

MsgBox "Приветствует последнее меню 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub MenuOnOff()

' Активация или деактивация пункта "Меню-Подменю1-Подменю2"

cbrcBar.Enabled = Not cbrcBar.Enabled

End Sub

Создание пользовательского меню (вариант 6)

Sub CreateMenu()

Dim cbrMenu As CommandBar

Dim cbrcNewMenu As CommandBarControl

 

' Удаление меню, если оно уже есть

Call DeleteMenu

' Добавление строки пользовательского меню

Set cbrMenu = CommandBars.Add(MenuBar:=True)

With cbrMenu

.Name = "Моя строка меню"

.Visible = True

End With

 

' Копирование стандартного меню "Файл"

CommandBars("Worksheet Menu Bar").FindControl(ID:=30002).Copy _

CommandBars("Моя строка меню")

 

' Добавление нового меню - "Дополнительно"

Set cbrcNewMenu = cbrMenu.Controls.Add(msoControlPopup)

cbrcNewMenu.Caption = "&Дополнительно"

 

' Добавление команды в новое меню

With cbrcNewMenu.Controls.Add(msoControlButton)

.Caption = "&Восстановить обычную строку меню"

.OnAction = "DeleteMenu"

End With

' Добавление команды в новое меню

With cbrcNewMenu.Controls.Add(Type:=msoControlButton)

.Caption = "&Справка"

End With

End Sub

 

Sub DeleteMenu()

' Пытаемся удалить меню (успешно, если оно ранее создано)

On Error Resume Next

CommandBars("Моя строка меню").Delete

On Error GoTo 0

End Sub

Список панелей инструментов и контекстных меню

Sub ListOfMenues()

Dim intRow As Integer ' Хранит текущую строку

Dim cbrBar As CommandBar

' Очистка всех ячеек текущего листа

Cells.Clear

intRow = 1 ' Начинаем запись с первой строки

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

и записываем информацию о каждом элементе в таблицу

For Each cbrBar In CommandBars

' Порядковый номер

Cells(intRow, 1) = cbrBar.Index

' Название

Cells(intRow, 2) = cbrBar.Name

' Тип

Select Case cbrBar.Type

    Case msoBarTypeNormal

       Cells(intRow, 3) = "Панель инструментов"

    Case msoBarTypeMenuBar

       Cells(intRow, 3) = "Строка меню"

   Case msoBarTypePopup

       Cells(intRow, 3) = "Контекстное меню"

End Select

' Встроенный элемент или созданный пользователем

Cells(intRow, 4) = cbrBar.BuiltIn

 

' Переходим на следующую строку

intRow = intRow + 1

Next

End Sub