«Bill Jelen, Mr. Excel Tracy Syrstad 800 East 96th Street Indianapolis, Indiana 46240 ?изнес-решения Применение VBA и макросов в Microsoft® Excel Билл Джелен, “Мистер Excel” Трейси Сирстад Москва • Санкт-Петербург • Киев ...»

Несмотря на то что Excel не позволяет разместить в примечании ‘‘настоящую’’ диаграмму, это можно сделать с ее изображением, как показано на рис. 13.7.

Рис. 13.7. “Диаграмма”, размещенная в примечании Чтобы поместить изображение диаграммы в примечание с помощью поль зовательского интерфейса Excel, выполните следующие действия.

1. Создайте требуемое изображение.

2. Создайте примечание и выделите соответствующую ячейку.

380 Часть II Автоматизация Excel 3. Выберите команду меню Excel Вставка Изменить примечание (Insert Edit Comment) или щелкните на ячейке правой кнопкой мыши и выбери те команду контекстного меню Изменить примечание (Edit Comment).

4. Щелкните правой кнопкой мыши на границе области примечания и выберите команду контекстного меню Формат примечания (Format 5. Перейдите во вкладку Цвета и линии (Colors and Lines) и раскройте список Цвет (Color), расположенный в области Заливка (Fill).

6. Выберите команду Способы заливки (Fill Effects), перейдите во вкладку Рисунок (Picture) открывшегося диалогового окна Способы заливки (Fill Effects) и щелкните на кнопке Рисунок (Picture).

7. Выберите требуемое изображение и щелкните на кнопке OK для закры тия диалогового окна Способы заливки. Еще раз щелкните на кнопке OK, для того чтобы закрыть диалоговое окно Формат примечания.

Чтобы ‘‘диаграмма’’, помещенная в примечание описанным выше образом, всегда содержала текущие сведения, включите следующий код VBA в обработ чик события SheetChange, срабатывающего при изменении исходных данных диаграммы (укажите требуемое имя файла изображения, название диаграммы, название рабочего листа, адрес ячейки и размер области примечания).

Sub PlaceGraph() Dim x As String, z As Range Application.ScreenUpdating = False x = "C:\XWMJGraph.gif" Set z = Worksheets("Диаграмма в примечании").Range("A3") On Error Resume Next z.Comment.Delete ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Export x With z.AddComment Range("A1").Activate Application.ScreenUpdating = True Замечательные возможности Excel VBA В следующих разделах рассматриваются макросы, демонстрирующие бога тые возможности Excel VBA.

Выделение ячейки с помощью условного форматирования Макрос Worksheet_SelectionChange любезно предоставлен Иваном Ф. Моалой (Ivan F. Moala), проживающим в Окленде, Новая Зеландия.

автор Web сайта The XcelFiles (www.xcelfiles.com), посвященного Иван задачам, решить которые с помощью Excel представляется невероятным или невозможным.

Следующий макрос выделяет активную ячейку с помощью условного фор матирования. Следует отметить, что макрос Worksheet_SelectionChange удаляет любое существующее условное форматирование рабочего листа, а также очищает буфер обмена, что приводит к затруднению выполнения опе раций вырезания, копирования и вставки данных.

'///////////////////////////////////////////////////// '// Исправлено 14 февраля 2003 - с комментариями '// Хуана Пабло Г. (Juan Pablo G.).

'// Локализованные версии Excel могут неправильно '// интерпретировать значение TRUE.

'// Воспользуемся фактом, что TRUE можно '// заменить любым целым числом, не равным 0.

'//////////////////////////////////////////////////// Const iInternational As Integer = Not (0) Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim iColor As Integer '// Примечание: этот макрос удаляет любое '// существующее условное форматирование!

'// Продолжить выполнение макроса, если '// пользователь выделит диапазон ячеек.

On Error Resume Next iColor = Target.Interior.ColorIndex '// Оставить действие строки On Error Resume Next '// в силе на случай возникновения ошибок смещения строк.

If iColor < 0 Then Else End If '// Проверить, совпадает ли цвет текста с цветом заливки.

If iColor = Target.Font.ColorIndex Then iColor = iColor + Cells.FormatConditions.Delete '// Выделение с помощью горизонтальной полосы.

With Range("A" & Target.Row, Target.Address) 'Rows(Target.Row).FormatConditions.Add Type:=2, Formula1:=iInternational ' "TRUE".FormatConditions(1).Interior.ColorIndex = iColor 382 Часть II Автоматизация Excel '// Выделение с помощью вертикальной полосы.

With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & _ Target.Offset(-1, 0).Address).FormatConditions.Add Type:=2, Formula1:=iInternational ' "TRUE".FormatConditions(1).Interior.ColorIndex = iColor Выделение ячейки без применения условного форматирования Макрос HighLight и вспомогательные макросы HighlightRight, HighlightLeft, HighlightUp, HighlightDown, DisableDelete и ReSet также любезно предоставлены Иваном Ф. Моалой.

Следующий макрос выделяет ячейку, которая была сделана активной в ре зультате использования клавиш управления курсором, без применения услов ного форматирования.

Альтернативный вариант макроса, выделяющего активную ячейку:

- не использует условное форматирование;

- сохраняет существующее условное форматирование рабочего листа;

- позволяет выполнять операции вырезания, Макрос создан Нейтом Оливером (Nate Oliver) для Альдо (Aldo).

Альдо предложил обработку нажатия клавиши.

См. дополнительные комментарии в коде.

'// Размещено в стандартном модуле.

Dim strCol As String Dim iCol As Integer Dim dblRow As Double Sub HighlightRight() Sub HighlightLeft() Sub HighlightUp() Sub HighlightDown() Sub HighLight(dblxRow As Double, iyCol As Integer, _ Optional dblZ As Double = 0) On Error GoTo NoGo strCol = Mid(ActiveCell.Offset(dblxRow, iyCol).Address, _ InStr(ActiveCell.Offset(dblxRow, iyCol).Address, "$") + 1, _ InStr(2, ActiveCell.Offset(dblxRow, iyCol).Address, "$") - 2) iCol = ActiveCell.Column dblRow = ActiveCell.Row '// Позволяет избежать мерцания экрана.

Application.ScreenUpdating = False With Range(strCol & ":" & strCol & "," & dblRow + dblZ & _ ":" & dblRow + dblZ).Select '// Сейчас экран следует обновить.

Application.ScreenUpdating = True.Item(dblRow + dblxRow).Activate End With NoGo:

End Sub Sub DisableDelete() Cells(ActiveCell.Row, ActiveCell.Column).Select Application.OnKey "{DEL}" End Sub Sub ReSet() Application.OnKey "{RIGHT}" Application.OnKey "{LEFT}" Application.OnKey "{UP}" Application.OnKey "{DOWN}" End Sub Транспонирование данных Макрос TransposeData любезно предоставлен Масару Каджи.

Следующий макрос транспонирует данные по заданному столбцу.

Sub TransposeData() Dim shOrg As Worksheet, shRes As Worksheet Dim rngStart As Range, rngPaste As Range Dim lngData As Long Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False Sheets("Транспонирование (результат)").Delete Application.DisplayAlerts = True On Error GoTo On Error GoTo terminate Set shOrg = Sheets("Транспонирование") Set shRes = Sheets.Add(After:=shOrg) shRes.Name = "Транспонирование (результат)" With shOrg 'Отсортировать.

.Cells.CurrentRegion.Sort Key1:=.[B2], Order1:=1, _ 384 Часть II Автоматизация Excel Key2:=.[C2], Order2:=1, Key3:=.[E2], Order3:=1, Header:=xlYes 'Скопировать заголовок.

.Rows(1).Copy shRes.Rows(1) 'Задать начальный диапазон.

Set rngPaste = shRes.[A65536].End(xlUp).Offset(1) rngStart.Offset(, -2).Resize(, 5).Copy rngPaste 'Копировать V1 в V14.

rngStart.Offset(, 2).Resize(lngData).Copy rngPaste.Offset(, 5).PasteSpecial Paste:=xlAll, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=True 'Копировать V1FP в V14FP.

rngStart.Offset(, 1).Resize(lngData).Copy rngPaste.Offset(, 19).PasteSpecial Paste:=xlAll, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=True Application.GoTo shRes.[A1] shRes.Cells.Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False If MsgBox("Удалить исходный рабочий лист?", 36) = 6 Then Application.DisplayAlerts = False Sheets("Транспонирование").Delete Application.DisplayAlerts = True terminate:

Function GetNextRange(ByVal rngSt As Range) As Long Do Until rngSt.Value rngSt.Offset(i).Value End Function Выделение и отмена выделения несмежных ячеек Макросы ModifyRightClick, DeselectActiveCell и DeselectActiveArea любезно предоставлены Томом Уртисом.

Чтобы отменить выделение ячейки или диапазона ячеек на рабочем листе, нужно щелкнуть на произвольной невыделенной ячейке. После выполнения этой операции выделение требуемых ячеек необходимо начинать заново, что весьма проблематично, если речь идет о большом количестве несмежных ячеек.

Следующий макрос добавляет в контекстное меню 2 новые команды:

Отменить выделение активной ячейки и Отменить выделение активной области (рис. 13.8).

Удерживая нажатой клавишу, щелкните левой кнопкой мыши на ячейке несмежного диапазона, выделение которой следует отменить. Щелк ните правой кнопкой мыши и выберите команду контекстного меню Отменить выделение активной ячейки (для отмены выделения только одной активной ячейки) или Отменить выделение активной области (для отмены выделения области, которой принадлежит активная ячейка).

Поместите приведенный ниже код в стандартный модуль.

Sub ModifyRightClick() Dim O1 As Object, O2 As Object On Error Resume Next With CommandBars("Cell").Controls("Отменить выделение активной ячейки").Delete.Controls("Отменить выделение активной области").Delete On Error GoTo Set O1 = CommandBars("Cell").Controls.Add.Caption = "Отменить выделение активной ячейки".OnAction = "DeselectActiveCell" Set O2 = CommandBars("Cell").Controls.Add.Caption = "Отменить выделение активной области".OnAction = "DeselectActiveArea" End Sub 386 Часть II Автоматизация Excel Sub DeselectActiveCell() If Selection.Cells.Count > 1 Then Sub DeselectActiveArea() If Selection.Areas.Count > 1 Then If Application.Intersect(ActiveCell, y) Is Nothing Then Разместите следующий код в модуле ЭтаКнига (ThisWorkbook).

Private Sub Workbook_Deactivate() Application.CommandBars("Cell").Reset Private Sub Workbook_Activate() ModifyRightClick VBA для профессионалов VBA программисты находятся в постоянном поиске более эффективных решений тех или иных задач. Размещая результаты своей работы в Internet, они оказывают неоценимую услугу всему сообществу VBA программистов.

Установка параметров страницы Макросы Macro1, Macro1_Version2, Macro1_Version3 и Macro1_ Version4 любезно предоставлены Хуаном Пабло Гонсалесом (Juan Pablo Gonzales), проживающим в Боготе, Колумбия. Хуан Пабло разработчик программы F&I Menu Wizard, он также выполняет для Mr.Excel.com все зака зы, поступающие от испаноязычных клиентов.

Следующие макросы выполняют одно и то же действие: устанавливают раз меры верхнего, нижнего, левого и правого полей страницы равными 1,5 дюйма (3,8 см), а размеры полей верхнего колонтитула и нижнего колонтитула рав ными 1 дюйму (2,5 см). Макрос Macro1 создан средством записи макросов.

Макросы Macro1_Version2, Macro1_Version3 и Macro1_Version4 де монстрируют возможность улучшения автоматически сгенерированного кода с целью повышения его производительности. На рис. 13.9 показана сравни тельная таблица скорости выполнения всех четырех макросов.

Рис. 13.9. Сравнительная таблица скорости выполнения макросов, устанавливающих параметры страницы Sub Macro1() ' Macro1 Macro ' Macro recorded 12/2/2003 by Juan Pablo Gonzalez With ActiveSheet.PageSetup.PrintTitleRows = "".PrintTitleColumns = "" ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup 388 Часть II Автоматизация Excel.LeftMargin = Application.InchesToPoints(1.5).RightMargin = Application.InchesToPoints(1.5).TopMargin = Application.InchesToPoints(1.5).BottomMargin = Application.InchesToPoints(1.5).HeaderMargin = Application.InchesToPoints(1).FooterMargin = Application.InchesToPoints(1).PrintComments = xlPrintNoComments.FirstPageNumber = xlAutomatic Как обычно, средство записи макросов создало весьма громоздкий код.

Учитывая низкую скорость обновления объекта PageSetup, макрос Macro остро нуждается в оптимизации, как показано ниже:

Sub Macro1_Version2() With ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(1.5).RightMargin = Application.InchesToPoints(1.5).TopMargin = Application.InchesToPoints(1.5).BottomMargin = Application.InchesToPoints(1.5).HeaderMargin = Application.InchesToPoints(1).FooterMargin = Application.InchesToPoints(1) Среднее время выполнения макроса Macro1_Version2 более чем на 70% меньше среднего времени выполнения макроса Macro1, однако это еще далеко не все. Принимая во внимание низкую скорость обновления объекта PageSetup, воспользуемся выражением If для установки значения только тех па раметров страницы, которые этого требуют.

В приведенном ниже макросе вызов функции Application.InchesToPoints был заменен фактическими значениями параметров страницы.

Sub Macro1_Version3() With ActiveSheet.PageSetup If.LeftMargin 108 Then.LeftMargin = If.RightMargin 108 Then.RightMargin = If.BottomMargin 108 Then.BottomMargin = If.HeaderMargin 72 Then.HeaderMargin = If.FooterMargin 72 Then.FooterMargin = Разница во времени выполнения макросов Macro1_Version2 и Macro1_ Version3 становится заметной при условии, что некоторые параметры стра ницы уже содержат нужные значения.

Макрос Macro1_Version4 вызывает XLM метод PAGE.SETUP, позволяя тем самым сократить среднее время своего выполнения более чем на 95% по сравнению со средним временем выполнения макроса Macro1. Параметры метода PAGE.SETUP left, right, top, bot, head_margin и foot_margin измеряются не в точках, а в дюймах.

Sub Macro1_Version4() Dim St As String St = "PAGE.SETUP(,, " & _ "1.5, 1.5, 1.5, 1.5" & _ ", 0, False, False, False, 1, 1, True, 1, 1,False,, " & _ Application.ExecuteExcel4Macro St End Sub Параметрам left, right, top и bot соответствует 4 я строка приведен ного выше кода, параметрам head_margin и foot_margin 6 я строка.

К сожалению, макрос Macro1_Version4 имеет два существенных недостат ка. Во первых, он основан на языке XLM, включенном в Excel для обеспече ния обратной совместимости. Неизвестно, как долго Microsoft намерена под держивать этот язык. Во вторых, ошибка при указании параметров метода PAGE.SETUP приведет к тому, что этот метод не будет выполнен без какого либо уведомления.

Вычисление времени выполнения кода макроса Ниже приведен код, использующийся для вычисления времени выполнения макросов Macro1, Macro1_Version2, Macro1_Version3 и Macro1_ Version4 (см. рис. 13.9).

Public Declare Function QueryPerformanceFrequency Lib _ "kernel32" (lpFrequency As Currency) As Long Public Declare Function QueryPerformanceCounter Lib _ "kernel32.dll" (lpPerformanceCount As Currency) As Long Sub Test() Dim Ar(1 To 20, 1 To 4) As Currency, WS As Worksheet Dim n As Currency, str As Currency, fin As Currency Dim y As Currency Dim i As Long, j As Long Application.ScreenUpdating = False Set WS = ThisWorkbook.Sheets.Add 390 Часть II Автоматизация Excel "##########.############") / y) With Range("A8").Resize(1, 4).Value = Array("Macro1", "Macro1_Version2", _ "Macro1_Version3", "Macro1_Version4") Range("A9").Resize(20, 4).Value = Ar With Range("A29").Resize(1, 4) ' В англоязычной версии Excel:

'.FormulaR1C1 = "=AVERAGE(R2C:R21C)".FormulaR1C1Local = "=СРЗНАЧ(R2C:R21C)" ' В англоязычной версии Excel:

'.Offset(1).FormulaR1C1 = "=RANK(R22C, R22C1:R22C4, 1)".Offset(1).FormulaR1C1Local = "=РАНГ(R22C; R22C1:R22C4; 1)" Application.ScreenUpdating = True Запрет/разрешение выполнения операций вырезания, копирования и вставки Макросы EnableAllClear и DisAbleAllCLear любезно предоставлены Иваном Ф. Моалой.

Иногда изменение пользователями содержимого рабочего листа крайне нежелательно. Следующий код запрещает/разрешает все способы выполнения операций вырезания, копирования и вставки данных.

Option Private Module Dim ComBar As CommandBar Dim ComBarCtrl As CommandBarControl Sub EnableAllClear() '// Команда Вставка (Insert)..

EnableControl 295, True '//..Ячейки (Cells) EnableControl 296, True '//..Строки (Rows) EnableControl 297, True '//..Столбцы (Columns) '// Команда...

EnableControl 478, True '// EnableControl 292, True '// EnableControl 293, True '// EnableControl 294, True '// EnableControl 847, True '// '// Команда...

EnableControl 3125, True '//

Contents), контекстное меню

EnableControl 1964, True '// EnableControl 872, True '// EnableControl 873, True '// EnableControl 874, True '// '// Команда...

EnableControl 21, True '// EnableControl 19, True '// EnableControl 22, True '// EnableControl 755, True '// '// Комбинации клавиш.

With Application.OnKey "+{INSERT}".CellDragAndDrop = True.OnDoubleClick = "" '// Панели инструментов.

CommandBars("ToolBar List").Enabled = True End Sub Sub DisAbleAllCLear() '// Команда Вставка (Insert)..

EnableControl 295, False '//..Ячейки (Cells) EnableControl 296, False '//..Строки (Rows) EnableControl 297, False '//..Столбцы (Columns) '// Команда...

EnableControl 478, False '// EnableControl 292, False '// EnableControl 293, False '// EnableControl 294, False '// EnableControl 847, False '// '// Команда...

EnableControl 21, False '// 392 Часть II Автоматизация Excel '// Команда...

EnableControl 3125, False '// Очистить содержимое (Clear

'// Contents), контекстное меню

EnableControl 1964, False '// Правка->Очистить->Все (All) EnableControl 872, False '// Правка->Очистить->Форматы EnableControl 873, False '// Правка->Очистить->Содержимое EnableControl 874, False '// Правка->Очистить->Примечания '// Комбинации клавиш.

'// Панели инструментов.

CommandBars("ToolBar List").Enabled = False Sub EnableControl(iId As Integer, blnState As Boolean) Dim ComBar As CommandBar Dim ComBarCtrl As CommandBarControl On Error Resume Next For Each ComBar In Application.CommandBars Set ComBarCtrl = ComBar.FindControl(Id:=iId, recursive:=True) If Not ComBarCtrl Is Nothing Then ComBarCtrl.Enabled = blnState Sub Dummy() MsgBox "Команда недоступна!" Определение порядка сортировки Макрос CustomSort любезно предоставлен Вэем Цзянгом (Wei Jiang), проживающим в г. Шиян, Китай. Цзянг работает на должности консультанта в компании MrExcel Consulting.

Excel поддерживает сортировку списков в числовом или алфавитном по рядке. Иногда этого оказывается недостаточно. Как показано на рис. 13.10, желаемый порядок сортировки списка выглядит так: ‘‘Пояса’’, ‘‘Сумки’’, ‘‘Часы’’, ‘‘Бумажники’’, ‘‘Все остальное’’.

Рис. 13.10. Желаемый порядок сортировки списка в Следующий макрос сортирует список с учетом заданного порядка сорти ровки.

Sub CustomSort() ' Задать желаемый порядок сортировки.

Application.AddCustomList ListArray:=Range("I1:I5") ' Определить номер списка, задающего порядок сортировки.

nIndex = Application.GetCustomListNum(Range("I1:I5").Value) ' Отсортировать список, используя заданный порядок сортировки.

' Номер списка, задающего порядок сортировки, равен nIndex + 1, ' поскольку обычный порядок сортировки имеет номер 1.

Range("A2:C16").Sort Key1:=Range("B2"), Order1:=xlAscending, _ Header:=xlNo, Orientation:=xlSortColumns, OrderCustom:=nIndex + Range("A2:C16").Sort Key1:=Range("A2"), Order1:=xlAscending, _ Header:=xlNo, Orientation:=xlSortColumns ' Удалить список, задающий порядок сортировки.

Application.DeleteCustomList nIndex End Sub Результат выполнения макроса CustomSort показан на рис. 13.11.

Рис. 13.11. В результате выполнения макроса список в ячейках A2:C16 отсортирован сперва по дате, а затем — в соответствии с порядком, заданным в столбце I 394 Часть II Автоматизация Excel Создание индикатора хода процесса Макрос Worksheet_Change любезно предоставлен Томом Уртисом.

Следующий макрос создает индикатор хода процесса в столбце C, основы ваясь на данных в столбцах A и B (рис. 13.12).

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column > 2 Or Target.Cells.Count > 1 Then Exit Sub If Application.IsNumber(Target.Value) = False Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "Введите число."

Select Case Target.Column If Target.Value > Target.Offset(0, 1).Value Then значения в столбце B."

If Target.Value < Target.Offset(0, -1).Value Then значения в столбце A."

x = Target.Row Dim z As String z = Range("B" & x).Value - Range("A" & x).Value With Range("C" & x) ' В англоязычной версии Excel: