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

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

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

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