Текстовые макросы для excel

#Руководства

  • 23 май 2022

  • 0

Как с помощью макросов автоматизировать рутинные задачи в Excel? Какие команды они выполняют? Как создать макрос новичку? Разбираемся на примере.

Иллюстрация: Meery Mary для Skillbox Media

Ксеня Шестак

Рассказывает просто о сложных вещах из мира бизнеса и управления. До редактуры — пять лет в банке и три — в оценке имущества. Разбирается в Excel, финансах и корпоративной жизни.

Макрос (или макрокоманда) в Excel — алгоритм действий в программе, который объединён в одну команду. С помощью макроса можно выполнить несколько шагов в Excel, нажав на одну кнопку в меню или на сочетание клавиш.

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

Например, если нужно добавить название компании в несколько десятков документов и отформатировать его вид под корпоративный дизайн, можно делать это в каждом документе отдельно, а можно записать ход действий при создании первого документа в макрос — и затем применить его ко всем остальным. Второй вариант будет гораздо проще и быстрее.

В статье разберёмся:

  • как работают макросы и как с их помощью избавиться от рутины в Excel;
  • какие способы создания макросов существуют и как подготовиться к их записи;
  • как записать и запустить макрос начинающим пользователям — на примере со скриншотами.

Общий принцип работы макросов такой:

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

Макросы могут выполнять любые действия, которые в них запишет пользователь. Вот некоторые команды, которые они умеют делать в Excel:

  • Автоматизировать повторяющиеся процедуры.

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

  • Объединять работу нескольких программ Microsoft Office.

    Например, с помощью одного макроса можно создать таблицу в Excel, вставить и сохранить её в документе Word и затем отправить в письме по Outlook.

  • Искать ячейки с данными и переносить их в другие файлы.

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

  • Форматировать таблицы и заполнять их текстом.

    Например, если нужно привести несколько таблиц к одному виду и дополнить их новыми данными, можно записать макрос при форматировании первой таблицы и потом применить его ко всем остальным.

  • Создавать шаблоны для ввода данных.

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

  • Создавать новые функции Excel.

    Если пользователю понадобятся дополнительные функции, которых ещё нет в Excel, он сможет записать их самостоятельно. Все базовые функции Excel — это тоже макросы.

Все перечисленные команды, а также любые другие команды пользователя можно комбинировать друг с другом и на их основе создавать макросы под свои потребности.

В Excel и других программах Microsoft Office макросы создаются в виде кода на языке программирования VBA (Visual Basic for Applications). Этот язык разработан в Microsoft специально для программ компании — он представляет собой упрощённую версию языка Visual Basic. Но это не значит, что для записи макроса нужно уметь кодить.

Есть два способа создания макроса в Excel:

  • Написать макрос вручную.

    Это способ для продвинутых пользователей. Предполагается, что они откроют окно Visual Basic в Еxcel и самостоятельно напишут последовательность действий для макроса в виде кода.

  • Записать макрос с помощью кнопки меню Excel.

    Способ подойдёт новичкам. В этом варианте Excel запишет программный код вместо пользователя. Нужно нажать кнопку записи и выполнить все действия, которые планируется включить в макрос, и после этого остановить запись — Excel переведёт каждое действие и выдаст алгоритм на языке VBA.

Разберёмся на примере, как создать макрос с помощью второго способа.

Допустим, специальный сервис автосалона выгрузил отчёт по продажам за три месяца первого квартала в формате таблиц Excel. Эти таблицы содержат всю необходимую информацию, но при этом никак не отформатированы: колонки слиплись друг с другом и не видны полностью, шапка таблицы не выделена и сливается с другими строками, часть данных не отображается.

Так выглядят таблицы с продажами автосалона в первоначальном виде
Скриншот: Skillbox Media

Пользоваться таким отчётом неудобно — нужно сделать его наглядным. Запишем макрос при форматировании таблицы с продажами за январь и затем применим его к двум другим таблицам.


Готовимся к записи макроса

Кнопки для работы с макросами в Excel находятся во вкладке «Разработчик». Эта вкладка по умолчанию скрыта, поэтому для начала разблокируем её.

В операционной системе Windows это делается так: переходим во вкладку «Файл» и выбираем пункты «Параметры» → «Настройка ленты». В открывшемся окне в разделе «Основные вкладки» находим пункт «Разработчик», отмечаем его галочкой и нажимаем кнопку «ОК» → в основном меню Excel появляется новая вкладка «Разработчик».

В операционной системе macOS это нужно делать по-другому. В самом верхнем меню нажимаем на вкладку «Excel» и выбираем пункт «Параметры…».

Нажимаем сюда, чтобы вызвать панель с дополнительными параметрами Excel в macOS
Скриншот: Skillbox Media

В появившемся окне нажимаем кнопку «Лента и панель».

Выбираем параметр «Лента и панель»
Скриншот: Skillbox Media

Затем в правой панели «Настроить ленту» ищем пункт «Разработчик» и отмечаем его галочкой. Нажимаем «Сохранить».

Отмечаем пункт «Разработчик» и сохраняем изменения
Скриншот: Skillbox Media

Готово — вкладка «Разработчик» появилась на основной панели Excel.

Теперь можно работать с макросами
Скриншот: Skillbox Media

Чтобы Excel смог сохранить и в дальнейшем использовать макрос, нужно пересохранить документ в формате, который поддерживает макросы. Это делается через команду «Сохранить как» на главной панели. В появившемся меню нужно выбрать формат «Книга Excel с поддержкой макросов».

Перед записью макросов нужно сохранить документ в формате с их поддержкой
Скриншот: Skillbox Media

Перед началом записи макроса важно знать об особенностях его работы:

  • Макрос записывает все действия пользователя.

    После старта записи макрос начнёт регистрировать все клики мышки и все нажатия клавиш. Поэтому перед записью последовательности лучше хорошо отработать её, чтобы не добавлять лишних действий и не удлинять код. Если требуется записать длинную последовательность задач — лучше разбить её на несколько коротких и записать несколько макросов.

  • Работу макроса нельзя отменить.

    Все действия, которые выполняет запущенный макрос, остаются в файле навсегда. Поэтому перед тем, как запускать макрос в первый раз, лучше создать копию всего файла. Если что-то пойдёт не так, можно будет просто закрыть его и переписать макрос в созданной копии.

  • Макрос выполняет свой алгоритм только для записанного диапазона таблиц.

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

Для начала записи макроса перейдём на вкладку «Разработчик» и нажмём кнопку «Записать макрос».

Нажимаем сюда, чтобы начать запись макроса
Скриншот: Skillbox Media

Появляется окно для заполнения параметров макроса. Нужно заполнить поля: «Имя макроса», «Сохранить в», «Сочетание клавиш», «Описание».

Так выглядит окно с параметрами макроса
Скриншот: Skillbox Media

«Имя макроса» — здесь нужно придумать и ввести название для макроса. Лучше сделать его логически понятным, чтобы в дальнейшем можно было быстро его найти.

Первым символом в названии обязательно должна быть буква. Другие символы могут быть буквами или цифрами. Важно не использовать пробелы в названии — их можно заменить символом подчёркивания.

«Сохранить в» — здесь нужно выбрать книгу, в которую макрос сохранится после записи.

Если выбрать параметр «Эта книга», макрос будет доступен при работе только в этом файле Excel. Чтобы макрос был доступен всегда, нужно выбрать параметр «Личная книга макросов» — Excel создаст личную книгу макросов и сохранит новый макрос в неё.

«Сочетание клавиш» — здесь к уже выбранным двум клавишам (Ctrl + Shift в системе Windows и Option + Cmd в системе macOS) нужно добавить третью клавишу. Это должна быть строчная или прописная буква, которую ещё не используют в других быстрых командах компьютера или программы Excel.

В дальнейшем при нажатии этих трёх клавиш записанный макрос будет запускаться автоматически.

«Описание» — необязательное поле, но лучше его заполнять. Например, можно ввести туда последовательность действий, которые планируется записать в этом макросе. Так не придётся вспоминать, какие именно команды выполнит этот макрос, если нужно будет запустить его позже. Плюс будет проще ориентироваться среди других макросов.

В нашем случае с форматированием таблицы заполним поля записи макроса следующим образом и нажмём «ОК».

Заполняем поля и жмём «ОК», чтобы начать запись
Скриншот: Skillbox Media

После этого начнётся запись макроса — в нижнем левом углу окна Excel появится значок записи.

Началась запись макроса — теперь в него попадут все клики мышки и нажатия клавиш
Скриншот: Skillbox Media

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

Важно: в нашем случае у таблиц продаж за январь, февраль и март одинаковое количество столбцов, но разное количество строк. Чтобы в случае со второй и третьей таблицей макрос сработал корректно, при форматировании выделим диапазон так, чтобы в него попали не только строки самой таблицы, но и строки ниже неё. Для этого нужно выделить столбцы в строке с их буквенным обозначением A–G, как на рисунке ниже.

Так макрос будет работать и для таблиц с большим количеством строк
Скриншот: Skillbox Media

Если выбрать диапазон только в рамках первой таблицы, то после запуска макроса в таблице с большим количеством строк она отформатируется только частично.

Так макрос отформатирует только выбранные строки: если в других таблицах строк окажется больше, они останутся в первоначальном виде
Скриншот: Skillbox Media

После всех манипуляций с оформлением таблица примет такой вид:

Так выглядит таблица после форматирования
Скриншот: Skillbox Media

Проверяем, все ли действия с таблицей мы выполнили, и останавливаем запись макроса. Сделать это можно двумя способами:

  • Нажать на кнопку записи в нижнем левом углу.
  • Перейти во вкладку «Разработчик» и нажать кнопку «Остановить запись».

Нажимаем сюда, чтобы остановить запись макроса
Скриншот: Skillbox Media

Готово — мы создали макрос для форматирования таблиц в границах столбцов A–G. Теперь его можно применить к другим таблицам.


Запускаем макрос

Перейдём в лист со второй таблицей «Февраль_2022». В первоначальном виде она такая же нечитаемая, как и первая таблица до форматирования.

Так выглядит таблица до запуска макроса
Скриншот: Skillbox Media

Отформатируем её с помощью записанного макроса. Запустить макрос можно двумя способами:

  • Нажать комбинацию клавиш, которую выбрали при заполнении параметров макроса — в нашем случае Option + Cmd + Ф.
  • Перейти во вкладку «Разработчик» и нажать кнопку «Макросы».

Нажимаем сюда, чтобы вызвать панель для выбора макроса
Скриншот: Skillbox Media

Появляется окно — там выбираем макрос, который нужно запустить. В нашем случае он один — «Форматирование_таблицы». Под ним отображается описание того, какие действия он включает. Нажимаем «Выполнить».

Нажимаем сюда, чтобы запустить макрос для форматирования таблицы
Скриншот: Skillbox Media

Готово — вторая таблица с помощью макроса форматируется так же, как и первая.

За пару секунд с помощью макроса исходная таблица принимает такой вид
Скриншот: Skillbox Media

То же самое можно сделать и на третьем листе для таблицы продаж за март. Более того, этот же макрос можно будет запустить и в следующем квартале, когда сервис автосалона выгрузит таблицы с новыми данными.

Научитесь: Excel + Google Таблицы с нуля до PRO
Узнать больше

Excel для Microsoft 365 Excel для Microsoft 365 для Mac Excel 2021 для Mac Excel 2019 Excel 2019 для Mac Excel 2016 Excel 2016 для Mac Excel 2013 Excel 2010 Еще…Меньше

Если у вас есть Microsoft Excel задачи, которые вы делаете несколько раз, вы можете записать макрос, чтобы автоматизировать эти задачи. Макрос — это действие или набор действий, которые можно выполнить сколько угодно раз. При создании макроса записуются щелчки мышью и нажатия клавиш. После создания макроса его можно отредактировать, чтобы внести незначительные изменения в его работу.

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

Процедура

Изображение значка

Перед записью макроса    

Макросы и средства VBA находятся на вкладке Разработчик, которая по умолчанию скрыта, поэтому сначала нужно включить ее. Дополнительные сведения см. в статье Отображение вкладки «Разработчик».

Вкладка "Разработчик" на ленте

Изображение значка

Запись макроса    

  1. В группе Код на вкладке Разработчик нажмите кнопку Запись макроса.

  2. При желании введите имя макроса в поле Имя макроса, введите сочетания клавиш в поле Сочетания клавиш и описание в поле Описание, а затем нажмите кнопку ОК, чтобы начать запись.

    Команда "Записать макрос" в группе "Код" на вкладке "Разработчик"

  3. Выполните действия, которые нужно автоматизировать, например ввести шаблонный текст или заполнить столбец данных.

  4. На вкладке Разработчик щелкните Остановить запись.

    Команда "Остановить запись" в группе "Код" на вкладке "Разработчик"

Изображение значка

Подробнее о макросах    

Вы можете узнать немного о языке программирования Visual Basic путем редактирования макроса.

Чтобы изменить макрос, в группе Код на вкладке Разработчик нажмите кнопку Макрос, выберите имя макроса и нажмите кнопку Изменить. При этом Visual Basic редактора.

Узнайте, как записанные действия отображаются как код. Возможно, какой-то код вам понятен, а часть может показаться немного неявным.

Поэкспериментируйте с кодом, закройте редактор Visual Basic и снова запустите макрос. На этот раз посмотрите, не произойдет ли что-то другое!

Дальнейшие действия

  • Дополнительные информацию о создании макроса см. в теме Создание и удаление макроса.

  • Чтобы узнать, как запускать макрос, см. в этой теме.

Процедура

Изображение значка

Перед записью макроса    

Убедитесь, что на ленте отображается вкладка Разработчик. По умолчанию вкладка Разработчик не отображается, поэтому сделайте следующее:

  1. Перейдите в Excel > параметры…> ленты & панель инструментов.

  2. В категории Настроить ленту в списке Основные вкладки установите флажок Разработчик, а затем нажмите кнопку Сохранить.

Изображение значка

Запись макроса    

  1. На вкладке Разработчик нажмите кнопку Запись макроса.

  2. При желании введите имя макроса в поле Имя макроса, введите сочетания клавиш в поле Сочетания клавиш и описание в поле Описание, а затем нажмите кнопку ОК, чтобы начать запись.

  3. Выполните действия, которые нужно автоматизировать, например ввести шаблонный текст или заполнить столбец данных.

  4. На вкладке Разработчик в группе Код нажмите кнопку Остановить запись.

Изображение значка

Подробнее о макросах    

Вы можете узнать немного о языке программирования Visual Basic путем редактирования макроса.

Чтобы изменить макрос, на вкладке Разработчик нажмите кнопку Макрос ,выберите имя макроса и нажмите кнопку Изменить. При этом Visual Basic редактора.

Узнайте, как записанные действия отображаются как код. Возможно, какой-то код вам понятен, а часть может показаться немного неявным.

Поэкспериментируйте с кодом, закройте редактор Visual Basic и снова запустите макрос. На этот раз посмотрите, не произойдет ли что-то другое!

Дополнительные сведения

Вы всегда можете задать вопрос специалисту Excel Tech Community или попросить помощи в сообществе Answers community.

Нужна дополнительная помощь?

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

Как записать самый простой макрос?

Для начала запишем самый легкий макрос — зададим в ячейке А1 формат вида 12 345:

  •  Открываем новую книгу, в ячейке А1 набираем шестизначное число 123456. Сейчас оно выдается без разделителей разрядов. Запишем макрос, который ставит эти разделители.
  •  Заходим на панели инструментов в закладку Вид*, находим кнопку Макросы, жмем Запись макроса. В появившемся окне задаем имя макроса и книгу, в которой хотим этот макрос сохранить.

Важно

Запустить макросы можно только из открытых книг, поэтому если вы планируете использовать записанные вами макросы довольно часто, стоит использовать специальную книгу макросов, которая автоматически открывается вместе с запуском сеанса Excel.

Если вы все-таки хотите хранить макросы в отдельном файле, эту книгу нужно сохранить, выбрав тип файла Книга Excel с поддержкой макросов. В противном случае после закрытия книги макросы будут стерты.

  •  Выбираем Сохранить в… —  Личная книга макросов и нажимаем Ок (рис. 1).

Рис. 1. Запись макроса в личную книгу макросов

  •  Записываем в макрос действия, которые хотим выполнить: вызываем контекстное меню Формат ячеек (можно воспользоваться комбинацией клавиш Сtrl+1) и задаем нужный нам формат числа: на закладке Число идем в блок (все форматы) и выбираем там формат вида # ##0.

К сведению

Этот формат можно задать и в блоке Числовой, но чуть позже вам станет ясно, почему мы воспользовались блоком Все форматы.

  •  На закладке Вид — Макросы выбираем пункт Остановить запись.

Второй, более быстрый способ остановить запись макроса — нажать на появившийся в левом нижнем углу синий квадратик (рис. 2.).

Мы рекомендуем

Всегда обращайте внимание на этот квадратик: если он появился на панели, значит, сейчас идет запись всех ваших действий в макрос. Не забывайте вовремя останавливать запись макроса, чтобы потом его не пришлось переделывать.

Проверяем, что макрос записан и работоспособен:

  •  в ячейку А2 вбиваем любое шестизначное число;
  •  запускаем макрос одним из двух способов: на закладке Вид — Макросы выбираем пункт Макросы или нажимаем комбинацию клавиш Alt+F8, находим в списке наш макрос и нажимаем кнопку Выполнить.

Рис. 2. Форматирование числа и остановка записи макроса

Итак, вы записали свой первый макрос! Примите поздравления. Теперь давайте познакомимся с личной книгой макросов и синтаксисом написания команд для макроса.

Личная книга макросов

По умолчанию Excel не отображает личную книгу макросов. Чтобы убедиться, что она открыта, выбираем на вкладке Вид кнопку Отобразить — в появившемся окне должна быть книга под именем PERSONAL.

Мы убедились, что книга открыта, но отображать ее не будем, чтобы потом по ошибке не закрыть ее. По сути, в этой книге нас интересует так называемый Исходный текст — блок, в котором записываются макросы. Чтобы увидеть это окно, нажмите клавиши Alt+F11 или кликните правой кнопкой мыши на ярлыке любого листа Excel и выберите в контекстном меню Исходный текст. Откроется окно VBA-кодирования в Excel (рис. 3). Оно состоит из двух блоков:

1. В левой части экрана окно Project – VBAProject — это проводник, в котором отображаются все открытые в данный момент книги Excel (даже если вы их не видите, как, например, книгу Personal). Работа с этим блоком аналогична работе в обычном проводнике — двойной клик по наименованию книги раскрывает ее содержимое. Нас интересует блок Modules — Module1. Кликаем левой кнопкой мыши дважды по этому объекту.

2. В правой части экрана откроется блок записи и редактирования макросов. Здесь уже автоматически записался Макрос1. Рассмотрим на его примере основную канву макроса.

Рис. 3. Окно VBA-кодирования в Excel

Синтаксис макроса

Макросы — это команды, написанные на языке VBA (Visual Basic for Applications). И синтаксис кода макроса не отличается от записи кода в Visual Basic.

Любой макрос имеет следующий вид:

Sub Имя_Макроса_Без_Пробелов()

‘ комментарии к макросу — они нужны для вас, VBA не воспринимает такие строки как команды

команды, написанные на языке VBA

End Sub

3 обязательных блока макроса:

1. Начало макроса. Всегда начинается с команды Sub. Далее идет имя макроса — оно может быть на русском языке, но не должно содержать пробелы и специальные символы.

В конце имени макроса всегда ставятся скобки () — они нужны, когда вы создаете свою функцию, в них указываются аргументы функции, но об этом сейчас речь не пойдет.

2. Блок команд. В нашем примере он состоит из одной строки: Selection.NumberFormat = «#,##0»

Каждая команда должна начинаться с новой строки. Если текст команды очень длинный и не помещается на экране, его можно разбить на несколько строк, заканчивая строку символом нижнего подчеркивания _ (далее в примере мы это увидим).

3. Конец макроса. Всегда обозначается как End Sub.

Есть и один необязательный блок — это комментарии, которые вы можете оставлять в любом месте внутри кода макроса, поставив перед началом комментариев знак апострофа ‘. Например, вы можете описать, что именно делает тот или иной макрос.

Обратите внимание!

Если вы хотите разместить комментарии в несколько строк, каждую новую строку надо начинать с апострофа.

Теперь запишем более сложный макрос и научимся понимать текст его кода.

Например, информационная система выдает отчет «Бюджет на месяц» без выделения групповых значений цветом или шрифтом.

Нам необходимо:

  •  выделить групповые строки полужирным шрифтом;
  •  отформатировать на печать — расположить отчет по центру листа, задать масштаб 75 %, вывести в колонтитулы название отчета (рис. 4).

Рис. 4. Изменения после написания макроса

Запишем алгоритм форматирования отчета в макрос.

Нажимаем кнопку записи макроса и выполняем следующие действия:

  •  Даем макросу имя Форматирование_БДР, в блоке описания записываем, что будет делать этот макрос (например, Выделяет жирным курсивом итоги, форматирует на печать). Жмем Ок.
  •  Выделяем столбцы А:С, ставим автофильтр — на закладке Данные находим кнопку Фильтр.
  •  По столбцу КОД задаем условие не содержит точку: Текстовые фильтры — Не содержит и в поле текста ставим символ точки без пробелов (рис. 5).

Рис. 5. Использование автофильтра по столбцу «КОД»

  •  Выделяем отфильтрованный диапазон и задаем ему полужирный шрифт.
  •  Снимаем автофильтр (повторное нажатие на закладке Данные кнопки Фильтр).
  •  Заходим в меню форматирования на печать (Кнопка Файл/Office — Печать — Предварительный просмотр — Параметры страницы) и задаем там три параметра:

1) на вкладке Страница задаем масштаб 75 %;

2) на вкладке Поля отмечаем пункт Горизонтально в блоке Центрировать на странице;

3) на вкладке Колонтитулы создаем верхний колонтитул с текстом Бюджет на январь.

  •  Выходим из параметров страницы.
  •  Заканчиваем запись макроса.
  •  Нажимаем Alt+F11 и смотрим, что получилось (см. рис. 4).

Код этого макроса уже гораздо длиннее и непонятнее, но легко читаем для знающих английский язык и азы программирования в VBA.

Правила написания команд в VBA

Любая команда макроса состоит из двух блоков, разделенных точкой:

Объект.Действие с объектом или свойство объекта

Объектами в Excel являются, например:

  •  книга: WorkBook, ActiveWorkbook;
  •  лист, листы: WorkSheet, ActiveSheet, Sheets;
  •  ячейка: Cells(1,1) — в скобках указываются номера строки (Row) и столбца (Column) ячейки на листе;
  •  диапазон ячеек (может быть и одна ячейка): Range(«А1:С5»), Range(«А1»);
  •  строки (Rows);
  •  столбцы (Columns);
  •  выделение (Selection) — выделенный в данный момент диапазон (это может быть как несколько смежных ячеек, так и смежные строки или столбцы).

Примеры действий с объектами:

  •  ActiveWorkbook.Save — сохранить рабочую книгу (та, которая была активна в момент вызова пользователем макроса);
  •  Sheets(«Лист3»).Name = «Отчет» — переименовать «Лист3» в «Отчет»;
  •  Sheets(«Отчет»).Activate — перейти на лист с названием «Отчет»;
  •  Range(«А1»).Copy — скопировать в буфер обмена данные из ячейки А1;
  •  Rows(«13:13»).Delete Shift:=xlUp — удалить строку 13 со сдвигом вверх.

Примеры свойств объектов:

  •  ActiveCell.FormulaR1C1 = «БДР» — в выделенной (активной) ячейке записан текст «БДР»;
  •  ActiveCell.Row < 65 — номер ряда активной ячейки меньше 65.

Помнить все названия объектов, команд и свойств для написания несложных макросов не обязательно. Вы всегда можете сначала записать ваши стандартные действия с отчетами в Excel, а потом отформатировать код макроса, убрав из него лишние действия или заменив некоторые заданные параметры (например, длину диапазона) на переменные (которые в дальнейшем макрос будет запрашивать у пользователя или рассчитывать самостоятельно).

Но об этом мы расскажем далее, а сейчас обратимся к коду нашего первого макроса, состоящего из одной строки:

Selection.NumberFormat = «#,##0»

Суть его в следующем: к объекту Выделенный диапазон (у нас одна ячейка, но это может быть и весь столбец/строка или диапазон смежных ячеек) применяется свойство Числовой формат вида # ##0 (если помните, именно этот формат мы выбрали в списке).

Код макроса Форматирование_БДР и расшифровка строк кода представлены в таблице.

 

Строка кода

Расшифровка

Sub Форматирование_БДР()

Начало макроса, имя макроса

Пустая строка комментариев (ставится автоматически при записи макроса)

‘ Форматирование_БДР Макрос

Автоматически добавленный комментарий при записи макроса — может быть удален без потери работоспособности макроса

‘ Выделяем жирным курсивом итоги, форматируем на печать

Автоматически добавленный комментарий при записи макроса из поля Описание

Пустая строка — не влияет на суть исполнения макроса, но их полезно добавлять для разделения блоков команд внутри кода

   Columns(«A:C»).Select

Выделить (Select) объект Столбцы (Columns) А:С

    Selection.AutoFilter

Применить автофильтр (AutoFilter) для выделенного диапазона (Selection)

    ActiveSheet.Range(«$A$1:$C$34″).AutoFilter Field:=1, Criteria1:=»<>*.*», _

Задать критерий отбора «не содержит точку»

        Operator:=xlAnd

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

Обратите внимание: предыдущая строка закончилась символом нижнего подчеркивания _, значит, текст команды не уместился на одну строку и окончание команды перенесено на следующую

    Range(«A1:C34»).Select

Выделить (Select) объект Диапазон (Range) А1:С34.

Обратите внимание: какой бы длины ни был ваш следующий отчет, для которого вы будете применять этот макрос, выделится всегда только диапазон до 34 строки!

Как сделать этот диапазон любой длины — обсудим немного позже

    Selection.Font.Bold = True

Для выделенного диапазона (Объект Selection) установить свойство «полужирный шрифт» (Font.Bold = True). Если нужно отменить какое-то свойство, пишем False

    Selection.AutoFilter

Снять автофильтр (при записи макроса это было повторное нажатие кнопки Фильтр на закладке Данные)

    With ActiveSheet.PageSetup

Начало процедуры With (используется, если далее перечисляются свойства или действия с одним и тем же объектом для компактности записи кода).

Для объекта ActiveSheet (Текущий лист) применить следующие параметры свойства PageSetup (Параметры печати):

        .PrintTitleRows = «»

Печатать на каждой странице сквозные строки — пусто (то есть данное свойство не задано пользователем)

        .PrintTitleColumns = «»

Печатать на каждой странице сквозные столбцы — пусто

    End With

Окончание процедуры With

    ActiveSheet.PageSetup.PrintArea = «»

Заданная область печати — пусто (то есть пользователь не ограничил область печати, следовательно, на экран будет выведено все, что есть на листе)

    With ActiveSheet.PageSetup

Начало процедуры With

Для объекта Текущий лист применить следующие параметры печати (цветом выделены те, которые мы изменили по сравнению со стандартными):

        .LeftHeader = «»

Левый верхний колонтитул — пусто

        .CenterHeader = «Бюджет на январь»

Центральный верхний колонтитул — задан текст пользователем

        .RightHeader = «»

Правый верхний колонтитул — пусто

        .LeftFooter = «»

Левый нижний колонтитул — пусто

        .CenterFooter = «»

Центральный нижний колонтитул — пусто

        .RightFooter = «»

Правый нижний колонтитул — пусто

        .LeftMargin = Application.InchesToPoints(0.708661417322835)

Размеры левого поля

        .RightMargin = Application.InchesToPoints(0.708661417322835)

Размеры правого поля

        .TopMargin = Application.InchesToPoints(0.748031496062992)

Размеры верхнего поля

        .BottomMargin = Application.InchesToPoints(0.748031496062992)

Размеры нижнего поля

        .HeaderMargin = Application.InchesToPoints(0.31496062992126)

Размеры верхнего колонтитула

        .FooterMargin = Application.InchesToPoints(0.31496062992126)

Размеры нижнего колонтитула

        .PrintHeadings = False

Не печатать заголовки строк и столбцов (False — пользователь не отметил этот пункт)

        .PrintGridlines = False

Не печатать сетку

        .PrintComments = xlPrintNoComments

Не печатать примечания

        .PrintQuality = 600

Качество печати — 600 точек на дюйм

        .CenterHorizontally = True

Центрировать на странице горизонтально (True — пользователь отметил этот пункт)

        .CenterVertically = False

Не центрировать по вертикали

        .Orientation = xlPortrait

Ориентация страницы — книжная

        .Draft = False

Пользователь не отметил пункт Черновая в блоке Печать

        .PaperSize = xlPaperA4

Размер бумаги А4

        .FirstPageNumber = xlAutomatic

Номер первой страницы — автоматически

        .Order = xlDownThenOver

Последовательность вывода страниц: вниз, потом вправо (пункт в блоке Печать)

        .BlackAndWhite = False

Пользователь не отметил пункт Черно-белая в блоке Печать

        .Zoom = 75

Масштаб 75 %

        .PrintErrors = xlPrintErrorsDisplayed

Пункт в блоке ПечатьОшибки ячеекКак на экране

        .OddAndEvenPagesHeaderFooter = False

Пользователь не задавал разные колонтитулы для четных и нечетных страниц (флажок в блоке Колонтитулы)

        .DifferentFirstPageHeaderFooter = False

Пользователь не задавал отдельный колонтитул для первой страницы (флажок в блоке Колонтитулы)

        .ScaleWithDocHeaderFooter = True

Флажок в блоке Колонтитулы – Изменять вместе с масштабом страницы отмечен пользователем

        .AlignMarginsHeaderFooter = True

Флажок в блоке Колонтитулы – Выровнять относительно полей страницы отмечен пользователем

        .EvenPage.LeftHeader.Text = «»

Текст колонтитулов для четных и первой страниц не задан

        .EvenPage.CenterHeader.Text = «»

        .EvenPage.RightHeader.Text = «»

        .EvenPage.LeftFooter.Text = «»

        .EvenPage.CenterFooter.Text = «»

        .EvenPage.RightFooter.Text = «»

        .FirstPage.LeftHeader.Text = «»

        .FirstPage.CenterHeader.Text = «»

        .FirstPage.RightHeader.Text = «»

        .FirstPage.LeftFooter.Text = «»

        .FirstPage.CenterFooter.Text = «»

        .FirstPage.RightFooter.Text = «»

    End With

Окончание процедуры With

End Sub

Окончание кода макроса

Редактирование макроса

Как видите, код макроса легко читаем и понятен. Кроме того, нам не надо нагромождать его лишними строками: так как в параметрах печати мы меняли только три пункта, остальные строки можем удалить (они будут установлены по умолчанию). Удалим ненужные строки, поставим комментарии и в итоге получим вот такой элегантный код:

Sub Форматирование_БДР()

‘ Макрос выделяет жирным курсивом итоги, форматирует отчет на печать

‘——————

‘ Выделяем столбцы и ставим фильтр по столбцу КОД

 Columns(«A:C»).Select

 Selection.AutoFilter

 ActiveSheet.Range(«$A$1:$C$34″).AutoFilter Field:=1, Criteria1:=»<>*.*», _

 Operator:=xlAnd

‘ Выделяем отфильтрованный диапазон полужирным шрифтом, снимаем фильтр

 Range(«A1:C34»).Select

 Selection.Font.Bold = True

 Selection.AutoFilter

 ‘ Форматируем на печать: верхний колонтитул, центрирование по горизонтали, масштаб 75 %

 With ActiveSheet.PageSetup

 .CenterHeader = «Бюджет на январь»

 .CenterHorizontally = True

 .Zoom = 75

 End With

End Sub

Ввод в код макроса функций и процедур

Теперь усложним код макроса, задав ему два параметра:

1. Название месяца отчета запрашиваем у пользователя.

2. Последняя строка отчета БДР (в случае если она плавающая) рассчитывается в коде макроса.

Функция InputBox

Чтобы запросить у пользователя месяц отчета, воспользуемся функцией Inputbox, которая выводит диалоговое окно, в котором пользователь может самостоятельно задать значение переменной, используемой в коде. Синтаксис функции InputBox:

Zapros = InputBox(«Текст запроса», <«Текст в шапке окна»>, <Значение по умолчанию>,…)

где Zapros — введенная вами переменная (имя придумываете вы сами), а в скобках через запятую перечисляются аргументы функции.

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

Для удобства присвойте полученное значение функции InputBox какой-нибудь введенной вами переменной, особенно если в коде макроса вы будете несколько раз использовать значение этой функции.

Важно

Имена вводимых переменных не должны совпадать с уже занятыми VBA словами под название объектов, свойств или функций!

В нашем примере присвоим результат вызова функции InputBox переменной Mes.

Например, нельзя завести свою переменную Range, Cells или Month — компилятор VBA предупредит вас, что делать этого нельзя, и не запустит макрос, пока вы не устраните ошибку (рис. 6).

Рис. 6. Пример ошибки при заведении переменной

Не забывайте любой текст в коде брать в кавычки! В противном случае компилятор VBA будет воспринимать этот текст как команды и выдавать ошибку, так как не сможет их обработать.

Итак, приступим к редактированию кода макроса. Добавим в самое начало кода макроса строки:

‘ Запрашиваем у пользователя месяц отчета

Mes = InputBox(«Введите название месяца отчета», , «Январь»)

Теперь при запуске макроса будет выводиться диалоговое окно, в котором пользователь самостоятельно сможет указать, за какой месяц этот отчет (рис. 7).

Рис. 7. Диалоговое окно для указания месяца

С помощью функции InputBox можно запросить у пользователя и длину отчета. Но мы научим Excel высчитывать ее самостоятельно. Для этого нам потребуется процедура While.

Процедура While

Используется в коде, если надо сделать одинаковые действия несколько раз подряд до тех пор, пока выполняется какое-либо условие. Синтаксис процедуры While:

Do While <условие, которое должно быть верным для выполнения процедуры>

 <список команд>

Loop

Условие может состоять из одного выражения или содержать несколько, перечисленных через оператор AND (то есть оба условия должны быть выполнены) или OR (достаточно выполнения только одного из перечисленных условий). Также условие обязательно должно содержать переменную-счетчик (это может быть номер строки или столбца ячейки, значения которой вы проверяете).

В список команд обязательно должна входить команда наращивания переменной-счетчика, иначе процедура зациклится (так как она постоянно будет сравнивать одно и то же значение) и макрос придется прерывать принудительно.

Если макрос ушел в цикл, прервите его с помощью комбинации клавиш Ctrl+Break и либо прекратите макрос (кнопка End), либо зайдите в код макроса и исправьте ошибку (кнопка Debug). Чтобы макрос не уходил в цикл, рекомендуется включить в блок условий «защиту от дурака». Например, добавляем в условие проверку, чтобы значение счетчика не превышало определенной, заведомо достаточной для нас величины.

Рассмотрим применение процедуры While для поиска конца отчета БДР.

Как видно на рис. 4, последняя строка отчета имеет код «500». Напишем процедуру, которая будет проверять значения в ячейках столбца «А» и остановит свои действия, когда найдет ячейку с кодом «500».

Обратите внимание!

Excel иногда воспринимает числа как текст, поэтому включим два условия проверки значения ячейки и добавим «защиту от дурака» на случай, если в форме отчета случайно затрется код последней строки.

Помним, что все текстовые значения надо брать в кавычки. Числа записываем без кавычек:

‘ Ищем последнюю строку отчета

Dim Row_End As Integer     ‘ Вводим переменную «счетчик номера строки»

Row_End = 1             ‘ Присваиваем ей номер 1

‘ Начинаем процедуру поиска последней строки отчета по коду «500»

Do While Cells(Row_End, 1).Value <> «500» And Cells(Row_End, 1).Value <> 500 And Row_End < 100

‘ До тех пор, пока код не равен 500 и номер строки меньше 100, выполняем наращивание счетчика

Row_End = Row_End +1

Loop

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

Теперь заменим в изначальном коде макроса номер последней ячейки (34) на переменную Row_End. Число 34 было частью текста А1:С34, а теперь нам надо часть текста заменить на переменную. Делается это с помощью символа амперсанд &:

«текст» & переменная & «текст».

В нашем случае ссылка на диапазон А1:С34 будет записана так: А1:С & Row_End.

Кроме того, вспоминаем, что и название отчета Бюджет на январь у нас тоже теперь содержит параметр и будет записываться так: Бюджет на & Mes.

Не забывайте оставлять пробелы в кавычках перед переменной-словом, иначе текст сольется.

Еще раз взглянем на получившийся код макроса:

Sub Форматирование_БДР()

‘ Макрос выделяет жирным курсивом итоги, форматирует отчет на печать

‘ ——————

‘ Запрашиваем у пользователя месяц отчета

Mes = InputBox(«Введите название месяца отчета», , «Январь»)

‘ Ищем последнюю строку отчета

Dim Row_End As Integer     ‘ Вводим переменную «счетчик номера строки»

Row_End = 1             ‘ Присваиваем ей номер 1

‘ Начинаем процедуру поиска последней строки отчета по коду «500»

‘ Критичным значением для «защиты от дурака» принимаем номер строки 100

Do While Cells(Row_End, 1).Value <> «500» And Cells(Row_End, 1).Value <> 500 And Row_End < 100

‘ До тех пор, пока код не равен 500 и номер строки меньше 100, выполняем наращивание счетчика

Row_End = Row_End +1

Loop

‘ Выделяем столбцы и ставим фильтр на КОД

 Columns(«A:C»).Select

 Selection.AutoFilter

 ActiveSheet.Range(«$A$1:$C$» & Row_End).AutoFilter Field:=1, Criteria1:=»<>*.*», _

 Operator:=xlAnd

‘ Выделяем отфильтрованный диапазон полужирным шрифтом, снимаем фильтр

 Range(«A1:C» & Row_End).Select

 Selection.Font.Bold = True

 Selection.AutoFilter

‘ Форматируем на печать: верхний колонтитул, центрирование по горизонтали, масштаб 75 %

 With ActiveSheet.PageSetup

 .CenterHeader = «Бюджет на » & Mes

 .CenterHorizontally = True

 .Zoom = 75

 End With

End Sub

Теперь макрос стал более универсальным. Добавим в него еще одну «защиту от дурака».

Если нам принципиально, правильно ли макрос нашел последнюю строку отчета, после окончания процедуры While (строка Loop) можно добавить блок проверки значения Row_End и запроса у пользователя подтверждения на продолжение макроса.

Для этого изучим функцию MsgBox, процедуру IF и команду Exit Sub.

Функция MsgBox

MsgBox — еще один способ общения с пользователем: сообщения ему какой-то информации по ходу выполнения макроса или запрос у него подтверждения по дальнейшим действиям макроса путем нажатия на кнопки вида Yes, No, Ок, Cancel.

Она имеет два вида записи:

1. Мы просто сообщаем пользователю какую-то информацию. В этом случае аргументы функции перечисляются сразу же за функцией, без использования скобок:

MsgBox «Текст сообщения», <Вид кнопок>, <«Текст в шапке окна»>,…

На экране отобразится диалоговое окно, и после нажатия пользователем кнопки Ок продолжится выполнение макроса (рис. 8).

Рис. 8. Первый вид записи функции MsgBox

Как и в случае с функцией InputBox, обязательным здесь является только первый аргумент — Текст сообщения. Остальные можно даже не указывать, сократив вид записи функции до вида:

2. Нам важно, что ответил пользователь, мы записываем его ответ в значение какой-то переменной (рис. 9). В этом случае аргументы функции заключаются в скобки, а перед функцией обязательно должна стоять переменная, в которую мы записываем, на какую кнопку нажал пользователь:

YesNo = MsgBox(«Текст сообщения», <Вид кнопок>, <«Текст в шапке окна»>,…)

Рис. 9. Второй вид записи функции MsgBox

Варианты вида кнопок:

  •  vbOKOnly — только кнопка ОК;
  •  vbOKCanсel — кнопки ОК и Cancel;
  •  vbYesNo — кнопки Yes и No;
  •  vbYesNoCancel — кнопки Yes, No и Cancel.

Соответственно в зависимости от нажатой кнопки значения функции MsgBox могут быть vbOK, vbCancel, vbYes или vbNo.

Процедура If

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

If <условие, которое должно быть верным> Then

 <список команд при выполнении указанного условия>

else

 <список команд при невыполнении указанного условия>

End If

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

Команда Exit Sub

Прекращает выполнение макроса. Обычно ее используют в ветках процедуры If при проверке допустимости дальнейшего исполнения макроса. Обратите внимание: ни одно действие после команды Exit Sub выполнено не будет. Поэтому если вы хотите сообщить пользователю о принудительном прекращении процедуры, команду MsgBox нужно расположить выше команды Exit Sub.

Итак, объединим новые знания в код «защиты от дурака» и запишем его после строки Loop:

‘ Проверяем, дошла ли процедура While до «критичной» строки 100

‘ и спрашиваем подтверждение о продолжении выполнения макроса

If Row_End = 100 Then      

YesNo = MsgBox(«Поиск последней строки отчета дошел до 100, продолжаем?», vbYesNo)

If YesNo = vbNo Then          ‘ Если нажата кнопка «No», то…

MsgBox «Процедура прервана пользователем»   ‘ 1. выдаем сообщение для пользователя,

Exit Sub          ‘ 2. останавливаем макрос

End If

End If

В нашем коде прошло вложение одной процедуры If в другую:

  •  сначала мы проверили, дошел ли счетчик Row_End до значения 100;
  •  если дошел, мы спрашиваем у пользователя, продолжать ли нам выполнение макроса;
  •  если пользователь ответил «нет», останавливаем макрос.

В обеих процедурах If мы опустили второй блок (else): если Row_End не достиг значения 100 или пользователь ответил «да», макрос просто покинет процедуру If и продолжит выполнять команды, написанные ниже.

Каждая процедура If должна заканчиваться командой End If. Если количество строк с командой If не будет соответствовать количеству строк с командой End If, компилятор VBA сообщит об ошибке и вам придется искать, где вы потеряли конец процедуры If.

Поэтому рекомендуется сразу писать обе строки, а потом уже наполнять процедуру командами.

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

Подведем итоги

Мы с вами научились:

  •  записывать макросы через команду Вид  Макросы  Запись макроса;
  •  редактировать автоматически записанный макрос, удалять из него лишние команды;
  •  унифицировать код макроса, вводя в него переменные, которые макрос запрашивает у пользователя или рассчитывает самостоятельно,

а также изучили функции InputBox и MsgBox, процедуры While и If, команду Exit Sub.

В следующем номере рассмотрим процедуру FOR, запишем макрос суммирования результирующих статей БДР, научимся тестировать макросы и выносить кнопки вызова макроса на панель быстрого доступа.


Статья опубликована в журнале «Справочник экономиста» № 4, 2016.

Введение

Всем нам приходится — кому реже, кому чаще — повторять одни и те же действия и операции в Excel. Любая офисная работа предполагает некую «рутинную составляющую» — одни и те же еженедельные отчеты, одни и те же действия по обработке поступивших данных, заполнение однообразных таблиц или бланков и т.д. Использование макросов и пользовательских функций позволяет автоматизировать эти операции, перекладывая монотонную однообразную работу на плечи Excel. Другим поводом для использования макросов в вашей работе может стать необходимость добавить в Microsoft Excel недостающие, но нужные вам функции. Например функцию сборки данных с разных листов на один итоговый лист, разнесения данных обратно, вывод суммы прописью и т.д.

Макрос — это запрограммированная последовательность действий (программа, процедура), записанная на языке программирования Visual Basic for Applications (VBA). Мы можем запускать макрос сколько угодно раз, заставляя Excel выполнять последовательность любых  нужных нам действий, которые нам не хочется выполнять вручную.

В принципе, существует великое множество языков программирования (Pascal, Fortran, C++, C#, Java, ASP, PHP…), но для всех программ пакета Microsoft Office стандартом является именно встроенный язык VBA. Команды этого языка понимает любое офисное приложение, будь то Excel, Word, Outlook или Access.

Способ 1. Создание макросов в редакторе Visual Basic

Для ввода команд и формирования программы, т.е. создания макроса необходимо открыть специальное окно — редактор программ на VBA, встроенный в Microsoft Excel.

  • В старых версиях (Excel 2003 и старше) для этого идем в меню Сервис — Макрос — Редактор Visual Basic (Toos — Macro — Visual Basic Editor).
  • В новых версиях (Excel 2007 и новее) для этого нужно сначала отобразить вкладку Разработчик (Developer). Выбираем Файл — Параметры — Настройка ленты (File — Options — Customize Ribbon) и включаем в правой части окна флажок Разработчик (Developer). Теперь на появившейся вкладке нам будут доступны основные инструменты для работы с макросами, в том числе и нужная нам кнопка Редактор Visual Basic (Visual Basic Editor)



    macro1.png:

К сожалению, интерфейс редактора VBA и файлы справки не переводятся компанией  Microsoft на русский язык, поэтому с английскими командами в меню и окнах придется смириться:

macro2.png

Макросы (т.е. наборы команд на языке VBA) хранятся в программных модулях. В любой книге Excel мы можем создать любое количество программных модулей и разместить там наши макросы. Один модуль может содержать любое количество макросов. Доступ ко всем модулям осуществляется с помощью окна Project Explorer в левом верхнем углу редактора (если его не видно, нажмите CTRL+R). Программные модули бывают нескольких типов для разных ситуаций:

  • Обычные модули — используются в большинстве случаев, когда речь идет о макросах. Для создания такого модуля выберите в меню Insert — Module. В появившееся окно нового пустого модуля можно вводить команды на VBA, набирая их с клавиатуры или копируя их из другого модуля, с этого сайта или еще откуда нибудь:

    macro3.png

  • Модуль Эта книга — также виден в левом верхнем углу редактора Visual Basic в окне, которое называется Project Explorer. В этот модуль обычно записываются макросы, которые должны выполнятся при наступлении каких-либо событий в книге (открытие или сохранение книги, печать файла и т.п.):

    macro4.png

  • Модуль листа — доступен через Project Explorer и через контекстное меню листа, т.е. правой кнопкой мыши по ярлычку листа — команда Исходный текст (View Source). Сюда записывают макросы, которые должны выполняться при наступлении определенных событий на листе (изменение данных в ячейках, пересчет листа, копирование или удаление листа и т.д.)

    macro5.png

 Обычный макрос, введенный в стандартный модуль выглядит примерно так:

macro6.png

Давайте разберем приведенный выше в качестве примера макрос Zamena:

  • Любой макрос должен начинаться с оператора Sub, за которым идет имя макроса и список аргументов (входных значений) в скобках. Если аргументов нет, то скобки надо оставить пустыми.
  • Любой макрос должен заканчиваться оператором End Sub.
  • Все, что находится между Sub и End Sub — тело макроса, т.е. команды, которые будут выполняться при запуске макроса. В данном случае макрос выделяет ячейку заливает выделенных диапазон (Selection) желтым цветом (код = 6) и затем проходит в цикле по всем ячейкам, заменяя формулы на значения. В конце выводится окно сообщения (MsgBox).

С ходу ясно, что вот так сразу, без предварительной подготовки и опыта в программировании вообще и на VBA в частности, сложновато будет сообразить какие именно команды и как надо вводить, чтобы макрос автоматически выполнял все действия, которые, например, Вы делаете для создания еженедельного отчета для руководства компании. Поэтому мы переходим ко второму способу создания макросов, а именно…

Способ 2. Запись макросов макрорекордером

Макрорекордер — это небольшая программа, встроенная в Excel, которая переводит любое действие пользователя на язык программирования VBA и записывает получившуюся команду в программный модуль. Если мы включим макрорекордер на запись, а затем начнем создавать свой еженедельный отчет, то макрорекордер начнет записывать команды вслед за каждым нашим действием и, в итоге, мы получим макрос создающий отчет как если бы он был написан программистом. Такой способ создания макросов не требует знаний пользователя о программировании и VBA и позволяет пользоваться макросами как неким аналогом видеозаписи: включил запись, выполнил операци, перемотал пленку и запустил выполнение тех же действий еще раз. Естественно у такого способа есть свои плюсы и минусы:

  • Макрорекордер записывает только те действия, которые выполняются в пределах окна Microsoft Excel. Как только вы закрываете Excel или переключаетесь в другую программу — запись останавливается.
  • Макрорекордер может записать только те действия, для которых есть команды меню или кнопки в Excel. Программист же может написать макрос, который делает то, что Excel никогда не умел (сортировку по цвету, например или что-то подобное).
  • Если во время записи макроса макрорекордером вы ошиблись — ошибка будет записана. Однако смело можете давить на кнопку отмены последнего действия (Undo) — во время записи макроса макрорекордером она не просто возрвращает Вас в предыдущее состояние, но и стирает последнюю записанную команду на VBA.

Чтобы включить запись необходимо:

  • в Excel 2003 и старше — выбрать в меню Сервис — Макрос — Начать запись (Tools — Macro — Record New Macro)
  • в Excel 2007 и новее — нажать кнопку Запись макроса (Record macro) на вкладке Разработчик (Developer)

Затем необходимо настроить параметры записываемого макроса в окне Запись макроса:

macro7.png

  • Имя макроса — подойдет любое имя на русском или английском языке. Имя должно начинаться с буквы и не содержать пробелов и знаков препинания.
  • Сочетание клавиш — будет потом использоваться для быстрого запуска макроса. Если забудете сочетание или вообще его не введете, то макрос можно будет запустить через меню Сервис — Макрос — Макросы — Выполнить (Tools — Macro — Macros — Run) или с помощью кнопки Макросы (Macros) на вкладке Разработчик (Developer) или нажав ALT+F8.
  • Сохранить в… — здесь задается место, куда будет сохранен текст макроса, т.е. набор команд на VBA из которых и состоит макрос.:
    • Эта книга — макрос сохраняется в модуль текущей книги и, как следствие, будет выполнятся только пока эта книга открыта в Excel
    • Новая книга — макрос сохраняется в шаблон, на основе которого создается любая новая пустая книга в Excel, т.е. макрос будет содержаться во всех новых книгах, создаваемых на данном компьютере начиная с текущего момента
    • Личная книга макросов — это специальная книга Excel  с именем Personal.xls, которая используется как хранилище макросов. Все макросы из Personal.xls загружаются в память при старте Excel и могут быть запущены в любой момент и в любой книге.

После включения записи и выполнения действий, которые необходимо записать, запись можно остановить командой Остановить запись (Stop Recording).

Запуск и редактирование макросов

Управление всеми доступными макросами производится в окне, которое можно открыть с помощью кнопки Макросы (Macros) на вкладке Разработчик (Developer) или — в старых версиях Excel — через меню Сервис — Макрос — Макросы (Tools — Macro — Macros):

macro8.png

  • Любой выделенный в списке макрос можно запустить кнопкой Выполнить (Run).
  • Кнопка Параметры (Options) позволяет посмотреть и отредактировать сочетание клавиш для быстрого запуска макроса.
  • Кнопка Изменить (Edit) открывает редактор Visual Basic (см. выше) и позволяет просмотреть и отредактировать текст макроса на VBA.

Создание кнопки для запуска макросов

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

Кнопка на панели инструментов в Excel 2003 и старше

Откройте меню Сервис — Настройка (Tools — Customize) и перейдите на вкладку Команды (Commands). В категории Макросы легко найти веселый желтый «колобок» — Настраиваемую кнопку (Custom button):

macro9.gif

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

macro10.gif

Кнопка на панели быстрого доступа в Excel 2007 и новее

Щелкните правой кнопкой мыши по панели быстрого доступа в левом верхнем углу окна Excel и выберите команду Настройка панели быстрого доступа (Customise Quick Access Toolbar):

macro11.png

Затем в открывшемся окне выберите категорию Макросы и при помощи кнопки Добавить (Add) перенесите выбранный макрос в правую половину окна, т.е. на панель быстрого доступа:

macro12.png

Кнопка на листе

Этот способ подходит для любой версии Excel. Мы добавим кнопку запуска макроса прямо на рабочий лист, как графический объект. Для этого:

  • В Excel 2003 и старше — откройте панель инструментов Формы через меню Вид — Панели инструментов — Формы (View — Toolbars — Forms)
  • В Excel 2007 и новее — откройте выпадающий список Вставить (Insert) на вкладке Разработчик (Developer) 

Выберите объект Кнопка (Button):

macro13.png

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

Создание пользовательских функций на VBA

Создание пользовательских функций или, как их иногда еще называют, UDF-функций (User Defined Functions) принципиально не отличается от создания макроса в обычном программном модуле. Разница только в том, что макрос выполняет последовательность действий с объектами книги (ячейками, формулами и значениями, листами, диаграммами и т.д.), а пользовательская функция — только с теми значениями, которые мы передадим ей как аргументы (исходные данные для расчета).

Чтобы создать пользовательскую функцию для расчета, например, налога на добавленную стоимость (НДС) откроем редактор VBA, добавим новый модуль через меню Insert — Module и введем туда текст нашей функции:

macro14.png

Обратите внимание, что в отличие от макросов функции имеют заголовок Function вместо Sub и непустой список аргументов (в нашем случае это Summa). После ввода кода наша функция становится доступна в обычном окне Мастера функций (Вставка — Функция) в категории Определенные пользователем (User Defined):

macro15.png

После выбора функции выделяем ячейки с аргументами (с суммой, для которой надо посчитать НДС) как в случае с обычной функцией:

macro16.png

Полезные макросы Excel для автоматизации рутинной работы с примерами применения для разных задач.

Примеры макросов для автоматизации работы

makrosy-filtra-svodnoy-tablicyМакросы для фильтра сводной таблицы в Excel.
Как автоматизировать фильтр в сводных таблицах с помощью макроса? Исходные коды макросов для фильтрации и скрытия столбцов в сводной таблице.

makros-svodnoy-tablicyМакрос для создания сводной таблицы в Excel.
Как автоматически сгенерировать сводную таблицу с помощью макроса? Исходный код VBA для создания и настройки сводных таблиц на основе исходных данных.

makrosy-dlya-formatirovaniya-yacheekМакросы для изменения формата ячеек в таблице Excel.
Как форматировать ячейки таблицы макросом? Изменение цвета шрифта, заливки и линий границ, выравнивание. Автоматическая настройка ширины столбцов и высоты строк по содержимому с помощью VBA-макроса.

makros-pereimenovat-listyМакрос для копирования и переименования листов Excel.
Как одновременно копировать и переименовывать большое количество листов одним кликом мышкой? Исходный код макроса, который умеет одновременно скопировать и переименовать любое количество листов.



Макросы и функции для обработки текстовых строк, сравнение и обработка текстовых переменных

  • Наверняка, вы сталкивались с ситуацией, когда необходимо производить поиск некоторого значения по всей книге Excel (искать частичное совпадение на всех листах активной книги)
     
    Штатными средствами Excel вывести поле для поиска на панель инструментов не удаётся, а вызывать каждый раз диалоговое окно нажатием комбинации клавиш Ctrl + F не всегда удобно.
    На помощь придёт эта…

  • Функции ChangeFileCharset и ChangeTextCharset предназначены для изменения кодировки символов в текстовых файлах и строках.
    Исходную и конечную (желаемую) кодировку можно задать в параметрах вызова функций.

    ВНИМАНИЕ: Функции чтения и сохранения текста в файл в заданной кодировке

    Список доступных на вашем компьютере кодировок можно найти в реестре Windows в ветке
    HKEY_CLASSES_ROOTMIMEDatabase…

  • Данные функции предназначены для работы с текстовыми файлами из VBA Excel.
    Используя эти функции, вы при помощи одной строки кода сможете записать текст из переменной в файл, или наоборот, загрузить содержимое текстового файла в переменную.
    Подразумевается, что текстовые файлы имеют формат ANSI (он же ASCII, он же windows-1251)

    ВНИМАНИЕ: См. также функции чтения и сохранения текста в файл в…

  • Поиск и подсветка результатов в Excel


    Макрос запрашивает строку для поиска, после чего ищет введенный текст в первом столбце листа, и подсвечивает результаты поиска.
     
    При запуске макроса появляется диалоговое окно (InputBox), позволяющее задать текст для поиска.
    Макрос подсвечивает красным цветом внутри ячейки текст, совпадающий с искомым
    (+ выделяет найденное полужирным начертанием)
    Перед началом поиска, цвет всех ячеек…


  • В данной статье показаны 2 способа быстрого поиска значений в двумерных массивах.
    Поскольку искомое значение может встретиться в нескольких строках обрабатываемого двумерного массива,
    оба способа получают на выходе отфильтрованный двумерный массив.

    Способы формирования отфильтрованных массивов — разные:
    первый способ использует функцию ArrAutofilterEx
    второй способ — функцию …


  • Макрос предназначен для создания текстовых файлов в кодировке UTF-8.
    Исходными данными является таблица Excel из 12 столбцов.
    Сначала, макрос создаёт папку для будущих текстовых файлов.
    Папка создаётся в том же каталоге, где расположена книга Excel.
    Далее, для каждой строки таблицы, макрос формирует подпапку,
    используя в качестве её названия текст из 7-го столбца таблицы.
    И потом, когда папка…

  • Данный макрос предназначен для поиска адресов электронной почты на листе Excel, с последующим выводом найденных адресов на отдельный лист.
    В прикреплённом файле, на первом листе («исходные данные»), ячейки заполнены неструктурированной информацией (смесь фамилий, адресов почты, прочей ненужной информации)
    Макрос вычленяет из текста ячеек адреса электронной почты, и выводит все найденные…

  • Окно вывода кодов символов для текущей ячейки


    Надстройка предназначена для быстрого просмотра кодов символов текста, введённого в ячейку.

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

    И вот в этих случаях на помощь приходит эта надстройка.

    С её помощью вы быстро обнаружите, что в похожих ячейках одни и те же буквы набраны в разных…

  • Результат транслитерации выделенного диапазона ячеек


    Надстройка для транслитерации или кодирования (замены символов их кодами) выделенного диапазона ячеек Excel
    При запуске надстройки в Excel формируется панель инструментов, при помощи которой можно выполнять следующие действия:

    Нажатием кнопки RU->EN выполнить транслитерацию выделенного диапазона ячеек

    Нажатием кнопки EN->RU выполнить транслитерацию выделенного диапазона ячеек

    В…

  • При попытке сохранить файл под именем, заданным пользователем, вы можете получить ошибку — если в имени файла (папки) присутствуют запрещённые символы.
    Этого легко избежать, если в процессе формирования имени файла удалить из него недопустимые символы, заменив их символом подчёркивания:
    Function Replace_symbols(ByVal txt As String) As String
    St$ = «~!@/#$%^&*=|`»»…

  • Зачастую требуется в функциях ввести дополнительный параметр, где пользователь может задать ссылку на ячейку
    (например, место для вставки данных)
    Поскольку фантазия некоторых пользователей ничем не ограничена, да и хочется сделать макрос универсальным, необходимо сделать так, чтобы пользователь мог задать параметр ЯчейкаДляВставки в любом виде — будь то ссылка на ячейку, строку или столбец, или…


  • При помощи функции Environ() можно получить значение переменной окружения Windows
     
    Этот макрос создаст новую книгу, и выведет в неё список из 31 переменной,
    с примерами вызова функции для получения каждого из параметров:
    Sub ВывестиПеременныеОкружения()
    On Error Resume Next
    Dim sh As Worksheet, param$
    Application.ScreenUpdating = False: Set sh = Workbooks.Add.Worksheets(1…

  • Скриншот результатов отображения промежуточных этапов вычислений формулы Excel


    Пользовательская функция ParseFormula предназначена для отображения промежуточных результатов вычисления простейших формул в Excel.
     
    В данной версии функции ParseFormula поддерживаются только 2 формулы: СУММ и ПРОИЗВЕД
    Пример её использования — в прикреплённом файле.

    В примере в голубых ячейках — исходные данные для формул,
    в оранжевых ячейках — формулы типа =ПРОИЗВЕД(A1…


  • Функция позволяет произвести замену в текстовой строке кодов символов Unicode на их значения
     
    В функции используются регулярные выражения (RegExp)
    Пример использования функции ReplaceUnicodeChars:
    Sub ЗаменаКодовСимволовВСтроке()
    ‘ исходная текстовая строка, содержащая коды символов Unicode
    txt$ = «Санаторийu2013профилакторий u201dЛесная сказкаu201d приглашает Вас!…


  • Данные функции могут быть полезны, если вы хотите спрятать некоторые значения в книге Excel
    Функция SaveValue предназначена для создания (изменения существующих) имён в книге, а функция GetValue — для получения ранее сохранённых значений.
    Sub SaveValue(ByRef WB As Workbook, ByVal Parameter As String, ByVal NewValue As String)
    ‘ создаёт в книге WB скрытое имя Parameter со значением NewValue…

  • Этот макрос позволяет преобразовать HTML-код, хранящийся в ячейках Excel,
    в обычный текст (без HTML-тегов)
    Особенность кода: теги перевода строки «br /» сохраняются.
    Пример использования процедуры Convert_HTML_Range_To_Text:
    (для этого примера, преобразования выполняются для диапазона ячеек в столбце С, начиная с 4 строки)
    Sub Макрос1()
    ‘ получаем ссылку на диапазон ячеек
    Dim ra As Range…


  • Функция ParseColumnsStringEx предназначена для преобразования введенного пользователем списка столбцов в одномерный массив числовых значений.
    Назначение функции: исключить ошибки пользовательского ввода, преобразовать буквенные названия столбцов в числовые значения.
    Пример использования:
    Private Sub ПримерИспользования_ParseColumnsStringEx()
    Dim txt$, txt1$, txt2$
    ‘ исходная строка с…

Представляю Вашему вниманию огромный сборник макросов и функций, все макросы сгруппированы по главам, для удобства добавил оглавление с гиперссылками.

P.S.: Где скачал не помню.


Запуск макроса с поиском ячейки
Запуск макроса при открытии книги
Запуск макроса при вводе в ячейку «2»
Запуск макроса при нажатии «Ентер»
Добавить в панель свою вкладку «Надстройки» (Формат ячейки)


Проверка наличия файла по указанному пути_1
Проверка наличия файла по указанному пути_2
Проверка наличия файла по указанному пути_3
Поиск нужного файла_1
Поиск нужного файла_2
Поиск нужного файла_3
Поиск нужного файла_4
Автоматизация удаления файлов
Произвольный текст в строке состояния
Восстановление строки состояния
Бегущая строка в строке состояния
Быстрое изменение заголовка окна
Быстрое изменение заголовка окна_2
Изменение заголовка окна (со скрытием названия файла)
Возврат к первоначальному заголовку
Что открыто в данный момент
Работа с текстовыми файлами
Запись и чтение текстового файла
Обработка нескольких текстовых файлов
Определение конца строки текстового файла
Копирование из текстового файла в эксель
Копирование содержимого в текстовый файл_1
Копирование содержимого в текстовый файл_2
Экспорт данных в HТМL
Создание резервных копий ценных файлов
Подсчет количества открытий файла
Вывод пути к файлу в активную ячейку
Копирование содержимого файла RTF в эксель
Копирование данных из закрытой книги
Извлечение данных из закрытого файла
Поиск слова в файлах
Создание текстового файла и ввод текста в файл
Создание текстового файла и ввод текста (определение конца файла)
Создание документов Word на основе таблицы Excel
Команды создания и удаления каталогов
Получение текущего каталога
Посмотреть все файлы в каталоге_1
Посмотреть все файлы в каталоге_2
Посмотреть все файлы в каталоге_3


Количество имен рабочей книги
Защита рабочей книги
Запрет печати книги
Открытие книги (или текстовых файлов)
Открытие книги и добавление в ячейку А1 текста
Сколько книг открыто
Закрытие всех книг
Закрытие рабочей книги только при выполнении условия
Сохранение рабочей книги с именем, представляющим собой текущую дату
Сохранена ли рабочая книга
Создать книгу с одним листом
Удаление ненужных имен
Быстрое размножение рабочей книги
Сортировка листов
Поиск максимального значения на всех листах книги
Проверка наличия защиты рабочего листа
Список отсортированных листов
Создать новый лист_1
Копирование листа в книге
Копирование листа в новую книгу (создается)
Перемещение листа в книге
Перемещение нескольких листов в новую книгу
Заменить существующий файл
Вставка колонтитула с именем книги, листа и текущей датой
Существует ли лист
Существует ли лист_2
Вывод количества листов в активной книге
Вывод количества листов в активной книге в виде гиперссылок
Вывод имен активных листов по очереди
Вывод имени и номеров листов текущей книги
Сделать лист невидимым
Сколько страниц на всех листах?
Копирование строк на другой лист
Копирование столбцов на другой лист
Подсчет количества ячеек, содержащих указанные значения_1
Подсчет количества ячеек в диапазоне, содержащих указанные значения_2
Подсчет количества видимых ячеек в диапазоне
Определение количества ячеек в диапазоне и суммы их значений
Подсчет количества ячеек
Автоматический пересчет данных таблицы при изменении ее значений
Ввод данных в ячейки
Ввод данных с использованием формул
Ввод текстоввых данных в ячейки
Вывод в ячейки названия книги, листа и количества листов
Удаление пустых строк_1
Удаление пустых строк_2
Удаление пустых строк_3
Удаление строки по условию
Удаление используемых скрытых строк или строк с нулевой высотой
Удаление дубликатов по маске
Выделение диапазона над текущей ячейкой
Выделение диапазона над текущей ячейкой_2
Выделение отрицательных значений
Выделение диапазона и использование абсолютных адресов
Выделение ячеек через интервал_2
Движение по ячейкам
Поиск ближайшей пустой ячейки столбца
Поиск максимального значения
Поиск и замена по шаблону
Поиск значения с отображением результата в отдельном окне
Поиск с выделением найденных данных_1
Поиск с выделением найденных данных_2
Поиск по условию в диапазоне
Поиск последней непустой ячейки диапазона
Поиск последней непустой ячейки столбца
Поиск последней непустой ячейки строки
Поиск ячейки синего цвета в диапазоне
Поиск наличия значения в столбце
Поиск совпадений в диапазоне
Поиск ячейки в диапазоне_1
Поиск ячейки в диапазоне_2
Поиск приближенного значения в диапазоне
Поиск начала и окончания диапазона, содержащего данные
Автоматическая замена значений
Быстрое заполнение диапазона (массив)
Заполнение через интервал(массив)
Заполнение указанного диапазона(массив)
Заполнение диапазона(массив)
Расчет суммы первых значений диапазона
Размещение в ячейке электронных часов
«Будильник»
Адрес активной ячейки
Координаты активной ячейки
Формула активной ячейки
Получение из ячейки формулы
Тип данных ячейки
Вывод адреса конца диапазона
Получение информации о выделенном диапазоне
Создание изменяемого списка (таблица)
Умножение выделенного диапазона на 2
Одновременное умножение всех данных диапазона
Деление диапазона на 100
Суммирование данных только видимых ячеек
Сумма ячеек с числовыми значениями
При суммировании — курсор внутри диапазона
Начисление процентов в зависимости от суммы_1
Начисление процентов в зависимости от суммы_2
Начисление процентов в зависимости от суммы_3
Сводный пример расчета комиссионного вознаграждения
Движение по диапазону
Сдвиг от выделенной ячейки
Создание заливки диапазона
Подбор параметра ячейки
Разбиение диапазона
Объединение данных диапазона
Объединение данных диапазона_2
Узнать максимальную колонку или строку.
Ограничение возможных значений диапазона
Тестирование скорости чтения и записи диапазонов
Открыть MsgBox при выборе ячейки
Скрытие строки
Скрытие нескольких строк
Скрытие столбца
Скрытие нескольких столбцов
Скрытие строки по имени ячейки
Скрытие нескольких строк по адресам ячеек
Скрытие столбца по имени ячейки
Скрытие нескольких столбцов по адресам ячеек
Мигание ячейки


Вывод на экран всех примечаний рабочего листа
Функция извлечения комментария
Список примечаний защищенных листов
Перечень примечаний в отдельном списке_1
Перечень примечаний в отдельном списке_2
Перечень примечаний в отдельном списке_3
Подсчет количества примечаний_1
Подсчет примечаний_3
Выделение ячеек с примечаниями
Отображение всех примечаний
Изменение цвета примечаний
Добавление примечаний
Добавление примечаний в диапазон по условию
Перенос комментария в ячейку и обратно
Перенос значений из ячейки в комментарий_1
Перенос значений из ячейки в комментарий_2


Дополнение панели инструментов
Добавление кнопки на панель инструментов
Панель с одной кнопкой
Панель с двумя кнопками
Создание панели справа
Вызов предварительного просмотра
Создание пользовательского меню (вариант 1)
Создание пользовательского меню (вариант 2)
Создание пользовательского меню (вариант 3)
Создание пользовательского меню (вариант 4)
Создание пользовательского меню (вариант 5)
Создание списка пунктов главного меню Excel
Создание списка пунктов контекстных меню
Отображение панели инструментов при определенном условии
Скрытие и отображение панелей инструментов
Создать подсказку к моим кнопкам
Создание меню на основе данных рабочего листа
Создание контекстного меню
Блокировка контекстного меню
Добавление команды в меню Сервис
Добавление команды в меню Вид
Создание панели со списком
Мультфильм с помощником в главной роли
Дополнение помощника текстом, заголовком, кнопкой и значком
Новые параметры помощника
Использование помощника для выбора цвета заливки


Функция INPUTBOX (через ввод значения)
Настройка ввода данных в диалоговом окне
Открытие диалогового окна (“Открыть файл”)_1
Вызов броузера из Экселя
Диалоговое окно ввода данных
Значения по умолчанию


Вывод списка доступных шрифтов
Выбор из текста всех чисел
Прописная буква только в начале текста
Подсчет количества повторов искомого текста
Выделение из текста произвольного элемента
Отображение текста «задом наперед»
Запуск таблицы символов из Excel


Получить имя пользователя
Вывод разрешения монитора
Получение информации об используемом принтере
Просмотр информации о дисках компьютера


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


Программа для составления кроссвордов
Игра «Минное поле»
Игра «Угадай животное»
Расчет на основании ячеек определенного цвета


Вызов функциональных клавиш
Расчет среднего арифметического значения
Перевод чисел в «деньги»
Поиск ближайшего понедельника
Подсчет количества полных лет
Расчет средневзвешенного значения
Преобразование номера месяца в его название
Использование относительных ссылок
Преобразование таблицы Excel в HТМL-формат
Генератор случайных чисел
Случайные числа — на основании диапазона
Применение функции без ввода ее в ячейку
Подсчет именованных объектов
Включение автофильтра с помощью макроса
Создание бегущей строки
Создание бегущей картинки
Вращающиеся автофигуры
Вызов таблицы цветов
Создание калькулятора
Склонение фамилии, имени и отчества


Вывод даты и времени_1
Вывод даты и времени_2
Получение системной даты
Извлечение даты и часов
Функция ДатаПолная

К сообщению приложен файл: macros.rar (83Kb)

ГЛАВА 1. МАКРОСЫ

Запуск макроса с поиском ячейки

Запуск макроса при открытии книги

Запуск макроса при вводе в ячейку «2»

Запуск макроса при нажатии «Ентер»

Добавить в панель свою вкладку «Надстройки» (Формат ячейки)

ГЛАВА 2. РАБОТА С ФАЙЛАМИ (Т.Е.ОБМЕН ДАННЫМИ С ТХТ, RTF, XLS И Т.Д.)

Проверка наличия файла по указанному пути_1

Проверка наличия файла по указанному пути_2

Проверка наличия файла по указанному пути_3

Поиск нужного файла_1

Поиск нужного файла_2

Поиск нужного файла_3

Поиск нужного файла_4

Автоматизация удаления файлов

Произвольный текст в строке состояния

Восстановление строки состояния

Бегущая строка в строке состояния

Быстрое изменение заголовка окна

Быстрое изменение заголовка окна_2

Изменение заголовка окна (со скрытием названия файла)

Возврат к первоначальному заголовку

Что открыто в данный момент

Работа с текстовыми файлами

Запись и чтение текстового файла

Обработка нескольких текстовых файлов

Определение конца строки текстового файла

Копирование из текстового файла в эксель

Копирование содержимого в текстовый файл_1

Копирование содержимого в текстовый файл_2

Экспорт данных в HТМL

Создание резервных копий ценных файлов

Подсчет количества открытий файла

Вывод пути к файлу в активную ячейку

Копирование содержимого файла RTF в эксель

Копирование данных из закрытой книги

Извлечение данных из закрытого файла

Поиск слова в файлах

Создание текстового файла и ввод текста в файл

Создание текстового файла и ввод текста (определение конца файла)

Создание документов Word на основе таблицы Excel

Команды создания и удаления каталогов

Получение  текущего каталога

Посмотреть все файлы в каталоге_1

Посмотреть все файлы в каталоге_2

Посмотреть все файлы в каталоге_3

ГЛАВА 3. РАБОЧАЯ ОБЛАСТЬ MICROSOFT EXCEL

Количество имен рабочей книги

Защита рабочей книги

Запрет печати книги

Открытие книги (или текстовых файлов)

Открытие книги и добавление в ячейку А1 текста

Сколько книг открыто

Закрытие всех книг

Закрытие рабочей книги только при выполнении условия

Сохранение рабочей книги с именем, представляющим собой текущую дату

Сохранена ли рабочая книга

Создать книгу с одним листом

Удаление ненужных имен

Быстрое размножение рабочей книги

Сортировка листов

Поиск максимального значения на всех листах книги

Проверка наличия защиты рабочего листа

Список отсортированных листов

Создать новый лист_1

Копирование листа в книге

Копирование листа в новую книгу (создается)

Перемещение листа в книге

Перемещение нескольких листов в новую книгу

Заменить существующий файл

Вставка колонтитула с именем книги, листа и текущей датой

Существует ли лист

Существует ли лист_2

Вывод количества листов в активной книге

Вывод количества листов в активной книге в виде гиперссылок

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

Вывод имени и номеров листов текущей книги

Сделать лист невидимым

Сколько страниц на всех листах?

Копирование строк на другой лист

Копирование столбцов на другой лист

Подсчет количества ячеек, содержащих указанные значения_1

Подсчет количества ячеек в диапазоне, содержащих указанные значения_2

Подсчет количества видимых ячеек в диапазоне

Определение количества ячеек в диапазоне и суммы их значений

Подсчет количества ячеек

Автоматический пересчет данных таблицы при изменении ее значений

Ввод данных в ячейки

Ввод данных с использованием формул

Ввод текстоввых данных в ячейки

Вывод в ячейки названия книги, листа и количества листов

Удаление пустых строк_1

Удаление пустых строк_2

Удаление пустых строк_3

Удаление строки по условию

Удаление используемых скрытых строк или строк с нулевой высотой

Удаление дубликатов по маске

Выделение диапазона над текущей ячейкой

Выделение диапазона над текущей ячейкой_2

Выделение отрицательных значений

Выделение диапазона и использование абсолютных адресов

Выделение ячеек через интервал_2

Движение по ячейкам

Поиск ближайшей пустой ячейки столбца

Поиск максимального значения

Поиск и замена по шаблону

Поиск значения с отображением результата в отдельном окне

Поиск с выделением найденных данных_1

Поиск с выделением найденных данных_2

Поиск по условию в диапазоне

Поиск последней непустой ячейки диапазона

Поиск последней непустой ячейки столбца

Поиск последней непустой ячейки строки

Поиск ячейки синего цвета в диапазоне

Поиск наличия значения в столбце

Поиск совпадений в диапазоне

Поиск ячейки в диапазоне_1

Поиск  ячейки в диапазоне_2

Поиск приближенного значения в диапазоне

Поиск начала и окончания диапазона, содержащего данные

Автоматическая замена значений

Быстрое заполнение диапазона (массив)

Заполнение через интервал(массив)

Заполнение указанного диапазона(массив)

Заполнение диапазона(массив)

Расчет суммы первых значений диапазона

Размещение в ячейке электронных часов

«Будильник»

Адрес активной ячейки

Координаты активной ячейки

Формула активной ячейки

Получение из ячейки формулы

Тип данных ячейки

Вывод адреса конца диапазона

Получение информации о выделенном диапазоне

Создание изменяемого списка (таблица)

Умножение выделенного диапазона на 2

Одновременное умножение всех данных диапазона

Деление диапазона на 100

Суммирование данных только видимых ячеек

Сумма ячеек с числовыми значениями

При суммировании — курсор внутри диапазона

Начисление процентов в зависимости от суммы_1

Начисление процентов в зависимости от суммы_2

Начисление процентов в зависимости от суммы_3

Сводный пример расчета комиссионного вознаграждения

Движение по диапазону

Сдвиг от выделенной ячейки

Создание заливки диапазона

Подбор параметра ячейки

Разбиение диапазона

Объединение данных диапазона

Объединение данных диапазона_2

Узнать максимальную колонку или строку.

Ограничение возможных значений диапазона

Тестирование скорости чтения и записи диапазонов

Открыть MsgBox при выборе ячейки

Скрытие строки

Скрытие нескольких строк

Скрытие столбца

Скрытие нескольких столбцов

Скрытие строки по имени ячейки

Скрытие нескольких строк по адресам ячеек

Скрытие столбца по имени ячейки

Скрытие нескольких столбцов по адресам ячеек

Мигание ячейки

ГЛАВА 4. РАБОТА С ПРИМЕЧАНИЯМИ

Вывод на экран всех примечаний рабочего листа

Функция извлечения комментария

Список примечаний защищенных листов

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

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

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

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

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

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

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

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

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

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

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

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

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

ГЛАВА 5 . ПОЛЬЗОВАТЕЛЬСКИЕ ВКЛАДКИ НА ЛЕНТЕ

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

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

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

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

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

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

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

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

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

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

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

Создание списка пунктов главного меню Excel

Создание списка пунктов контекстных меню

Отображение панели инструментов при определенном условии

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

Создать подсказку к моим кнопкам

Создание меню на основе данных рабочего листа

Создание контекстного меню

Блокировка контекстного меню

Добавление команды в меню Сервис

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

Создание панели со списком

Мультфильм с помощником в главной роли

Дополнение помощника текстом, заголовком, кнопкой и значком

Новые параметры помощника

Использование помощника для выбора цвета заливки

ГЛАВА 6. ДИАЛОГОВЫЕ ОКНА

Функция INPUTBOX (через ввод значения)

Настройка ввода данных в диалоговом окне

Открытие диалогового окна (“Открыть файл”)_1

Вызов броузера из Экселя

Диалоговое окно ввода данных

Значения по умолчанию

ГЛАВА 7.ФОРМАТИРОВАНИЕ ТЕКСТА. ТАБЛИЦЫ. ГРАНИЦЫ И ЗАЛИВКА.

Вывод списка доступных шрифтов

Выбор из текста всех чисел

Прописная буква только в начале текста

Подсчет количества повторов искомого текста

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

Отображение текста «задом наперед»

Запуск таблицы символов из Excel

ГЛАВА 8 ИНФОРМАЦИЯ О ПОЛЬЗОВАТЕЛЕ, КОМПЬЮТЕРЕ, ПРИНТЕРЕ И Т.Д.

Получить имя пользователя

Вывод разрешения монитора

Получение информации об используемом принтере

Просмотр информации о дисках компьютера

ГЛАВА 9. ДИАГРАММЫ

Построение диаграммы с помощью макроса

Сохранение диаграммы в отдельном файле

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

Применение случайной цветовой палитры

Эффект прозрачности диаграммы

Построение диаграммы на основе данных нескольких рабочих листов

Создание подписей к данным диаграммы

ГЛАВА 10. РАЗНЫЕ ПРОГРАММЫ.

Программа для составления кроссвордов

Игра «Минное поле»

Игра «Угадай животное»

Расчет на основании ячеек определенного цвета

ГЛАВА 11. ДРУГИЕ ФУНКЦИИ И МАКРОСЫ

Вызов функциональных клавиш

Расчет среднего арифметического значения

Перевод чисел в «деньги»

Поиск ближайшего понедельника

Подсчет количества полных лет

Расчет средневзвешенного значения

Преобразование номера месяца в его название

Использование относительных ссылок

Преобразование таблицы Excel в HТМL-формат

Генератор случайных чисел

Случайные числа — на основании диапазона

Применение функции без ввода ее в ячейку

Подсчет именованных объектов

Включение автофильтра с помощью макроса

Создание бегущей строки

Создание бегущей картинки

Вращающиеся автофигуры

Вызов таблицы цветов

Создание калькулятора

Склонение фамилии, имени и отчества

ГЛАВА 12. ДАТА И ВРЕМЯ

Вывод даты и времени_1

Вывод даты и времени_2

Получение системной даты

Извлечение даты и часов

Функция ДатаПолная

ГЛАВА 1. МАКРОСЫ

Запуск макроса с поиском ячейки

‘ Sub  GotoFixedCell:

‘ Делает активной ячейку, содержащую значение vVariant на

‘ рабочем листе sSheetName в активной рабочей книге.

‘ Note: Содержимое ячеек интерпретируется как ‘значение’!

Public Sub GotoFixedCell(vValue As Variant, sSheetName As String)

  Dim c As Range, cStart As Range, cForFind As Range

  Dim i As Integer

  On Error GoTo errhandle:

  Set cForFind = Worksheets(sSheetName).Cells   ‘ Диапазон поиска

     With cForFind

       Set c = .Find(What:=vValue, After:=ActiveCell, LookIn:=xlValues, _

                LookAt:= xlРart, SearchOrder:=xlByRows,_

                SearchDirection:=xlNext, MatchCase:=False)

       Set cStart = c

       While Not c Is Nothing

         Set c = .FindNext(c)

         If c.Address = cStart.Address Then

           c.Select

           Exit Sub

         End If

       Wend

     End With

  Exit Sub

  errНandle:

    MsgBox Err.Descriрtion, vbExclamation, «Error #» & Err.Number

End Sub

Запуск макроса при открытии книги

Sub Auto_Oрen()

Запуск макроса при вводе в ячейку «2»

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim w As Object

    ‘On Error Resume Next

    If Range(«A1»).Value = 2 Then

        MsgBox «Ох! Значение ячейки стало равным 2-м!»

        MsgBox «Я попробую сейчас открыть модуль с процедурой, которая все это делает!»

        Application.VBE.MainWindow.SetFocus

        Application.VBE.Windows(1).SetFocus

        SendKeys «{F7}», True

    End If

End Sub

Запуск макроса при нажатии «Ентер»

в модуле листа

Private Sub Worksheet_Selectiоnchange(ByVal Target As Range)

Application.OnKey «{~}», «StartEnter»

End Sub

в модуле книги

Sub StartEnter()

MsgBox («sadfsdfsf»)

End Sub

Добавить в панель свою вкладку «Надстройки» (Формат ячейки)

Код в модуле рабочего листа

Sub Worksheet_Change(ByVal Target As Excel.Range)

   Call updаtеToolbar

End Sub

Sub Worksheet_Selectiоnchange(ByVal Target As Excel.Range)

   Call updаtеToolbar

End Sub

Листинг 2.43. Код в стандартном модуле

Sub FastChangeNumberFormat()

   Dim bar As CommandBar

   Dim button As CommandBarButton

   ‘ Удаление существующей панели инструментов (если она есть)

   On Error Resume Next

   CommandBars(«Числовой формат»).Delete

   On Error GoTo 0

   ‘ Формирование новой панели

   Set bar = CommandBars.Add

   With bar

      .Name = «Числовой формат»

      .Visible = True

   End With

   ‘ Создание кнопки

   Set button = CommandBars(«Числовой формат»).Controls.Add _

    (Type:=msoControlButton)

   With button

      .Caption = «»

      .OnAction = «ChangeNumFormat»

      .TooltipText = «Щелкните для изменения числового формата»

      .Style = msoButtonCaption

   End With

   ‘ Обновление созданной панели инструментов

   Call updаtеToolbar

End Sub

Sub updаtеToolbar()

   ‘ Обновление панели инструментов (если она создана)

   On Error Resume Next

   ‘ Изменение заголовка кнопки (на название формата выделенной ячейки)

   CommandBars(«Числовой формат»).Controls(1).Caption = _

    ActiveCell.NumberFormat

End Sub

Sub ChangeNumFormat()

   ‘ Отображение диалогового окна изменения формата ячейки

   Application.Dialogs(xlDialogFormatNumber).Show

   Call updаtеToolbar

End Sub

ГЛАВА 2. РАБОТА С ФАЙЛАМИ (Т.Е.ОБМЕН ДАННЫМИ С ТХТ, RTF, XLS И Т.Д.)

Проверка наличия файла по указанному пути_1

Sub VerifyFileLocation()

   Dim strFileName As String

   Dim strFileTitle As String

   ‘ Имя и путь искомого файла

   strFileTitle = «primer.xls»

   strFileName = «C:Документыprimer.xls»

   ‘ Проверка наличия файла (функция Dir возвращает пустую _

    строку, если по указанному пути файл обнаружить не удалось)

   If Dir(strFileName) <> «» Then

      MsgBox «Файл » & strFileTitle & » найден»

   Else

      MsgBox «Файл » & strFileTitle & » не найден»

   End If

End Sub

Проверка наличия файла по указанному пути_2

Sub VerifyFileLocation1()

   Dim strFileName As String

   ‘ Имя искомого файла

   strFileName = «C:Документыprimer.xls»

   ‘ Проверка наличия файла (функция Dir возвращает пустую _

    строку, если по указанному пути файл обнаружить не удалось)

   If Dir(strFileName) <> «» Then

      MsgBox «Файл » & strFileName & » найден»

   Else

      MsgBox «Файл » & strFileName & » не найден»

   End If

End Sub

Проверка наличия файла по указанному пути_3

Sub Check_Disk()

On Error Resume Next

If Dir(«\192.168.1.200c», vbSystem) <> «» Then

If Err = 52 Then

Err.Clear

MsgBox «Диска нет!», 48, «Ошибка»

Exit Sub

End If

If Err <> 0 Then

MsgBox «Произошло ошибка!», 48, «Ошибка»

Exit Sub

Else

On Error GoTo 0

MsgBox «Диск есть!», 64, «»

End If

End If

End Sub

Поиск нужного файла_1

Sub FileSearch()

   Dim strFileName As String

   Dim strFolder As String

   Dim strFullPath As String

   ‘ Задание имени папки для поиска

   strFolder = InputBox(«Определите папку:»)

   If strFolder = «» Then Exit Sub

   ‘ Задание имени файла для поиска

   strFileName = Application.InputBox(«Введите имя файла:»)

   If strFileName = «» Then Exit Sub

   ‘ При необходимости дополняем имя папки «»

   If Right(strFolder, 1) <> «» Then strFolder = strFolder & «»

   ‘ Полный путь файла

   strFullPath = strFolder & strFileName

   ‘ Вывод окна с отчетом о поиске средствами VBA

   MsgBox «Использование команды VBA…» & vbCrLf & vbCrLf & _

    dhSearchVBA(strFullPath), vbInformation, strFullPath

   ‘ Вывод окна с отчетом о поиске средствами объекта FileSearch

   MsgBox «Использование объекта FileSearch…» & vbCrLf & _

    vbCrLf & dhSearchFileSearch(strFolder, strFileName), vbInformation, _

    strFullPath

   ‘ Вывод окна с отчетом о поиске средствами объекта _

    FileSystemObject

   MsgBox «Использование объекта FileSystemObject…» & vbCrLf & _

    vbCrLf & dhSearchFileSystemObject(strFullPath), vbInformation, _

    strFullPath

End Sub

Поиск нужного файла_2

Function dhSearchVBA(varFullPath As Variant) As Boolean

   ‘ Использование команды VBA

   dhSearchVBA = Dir(varFullPath) <> «»

End Function

Поиск нужного файла_3

Function dhSearchFileSearch(varFolder As Variant, varFileName _

 As Variant) As Boolean

   ‘ Использование объекта FileSearch

   With Application.FileSearch

      ‘ Создание нового поиска

      .NewSearch

      ‘ Имя для поиска

      .FileName = varFileName

      ‘ Папка поиска

      .LookIn = varFolder

      ‘ Собственно поиск

      .Execute

      dhSearchFileSearch = .FoundFiles.Count <> 0

   End With

End Function

Поиск нужного файла_4

Function dhSearchFileSystemObject(varFullPath As Variant) As Boolean

   Dim objFSObject As Object

   ‘ Использование объекта FileSystemObject

   Set objFSObject = CreateObject(«sсriрting.FileSystemObject»)

   dhSearchFileSystemObject = objFSObject.FileExists(varFullPath)

End Function

Автоматизация удаления файлов

Листинг 3.51. Удаление файла

Sub DeleteFile()

   Kill «C:Документыprimer.xls»

End Sub

Листинг 3.52. Удаление группы файлов

Sub DeleteFiles()

   ‘ Удаление всех файлов с расширением XLS из заданной папки

   Kill «C:Документы» & «*.xls»

End Sub

Произвольный текст в строке состояния

Sub ChangeStatusBarText()

   Application.StatusBar = «Как надоело работать!!!»

End Sub

Восстановление строки состояния

Sub ReturnStatusBarText()

   Application.StatusBar = False

End Sub

Бегущая строка в строке состояния

Sub MovingTextInStatusBar()

   Dim intSpaces As Integer

   ‘ Изменение количества пробелов в начале строки (от 20 до 0) — _

    строка бежит (скорее, ползет) влево

   For intSpaces = 20 To 0 Step -1

      ‘ Запись текста в строку состояния

      Application.StatusBar = Space(intSpaces) & «Как надоело работать!!!»

      ‘ Выдерживаем паузу

      Application.Wait Now + TimeValue(«00:00:01»)

      ‘ Дадим Excel обработать пользовательский ввод

      DoEvents

   Next

   Application.StatusBar = False

End Sub

Быстрое изменение заголовка окна

Sub NewTitle()

   Application.Caption = «Какая хорошая погода»

End Sub

Быстрое изменение заголовка окна_2

Sub NewTitle()

   Application.Caption = «Какая хорошая погода»

   ActiveWindow.Caption = «А завтра будет дождь»

End Sub

Изменение заголовка окна (со скрытием названия файла)

Sub NewTitle()

   Application.Caption = «Какая хорошая погода»

   ActiveWindow.Caption = «»

End Sub

Возврат к первоначальному заголовку

Sub ReturnTitle()

   ‘ Возвращение заголовка приложения (то есть Excel)

   Application.Caption = Empty

   ‘ Указание правильного названия открытого файла (книги)

   ActiveWindow.Caption = ThisWorkbook.Name

End Sub

Что открыто в данный момент

Sub WorkBooksList()

   Dim book As Object

   ‘ Вывод имени каждой рабочей книги

   For Each book In Workbooks

      MsgBox (book.Name)

   Next

End Sub

Работа с текстовыми файлами

Открываются файлы командой Open, а закрываются — командой Close.

Sub Test()

   Open «file.txt» For Input As #1

   Close #1

End Sub

Запись и чтение текстового файла

Sub Test()

   Open «file.txt» For Output As #1

   Print #1, «Этот текст будет записан в файл»

   Close #1

   Open «file.txt» For Input As #1

   Dim s As String

   Input #1, s

   MsgBox s

   Close #1

End Sub

Для записи используется оператор Print, а для чтения — Input. У этих операторов есть свои особенности.

Print #1, «Hello , File»

Оператор Input #1 прочитает только Hello и все. Запятая воспринимается как разделитеть. Чтобы прочитать строку целиком, используется оператор Line Input.

Sub Test()

   Open «file.txt» For Output As #1

   Print #1, «Hello , File»

   Close #1

   Open «file.txt» For Input As #1

   Dim s As String

   Line Input #1, s

   MsgBox s

   Close #1

End Sub

Обработка нескольких текстовых файлов

Sub ImportTextFiles()

   Dim fsSearch As FileSearch

   Dim strFileName As String

   Dim strPath As String

   Dim i As Integer

   ‘ Задание пути и возможного имени файла

   strFileName = ThisWorkbook.path & «»

   strPath = «text??.txt»

   ‘ Создание объекта FileSearch

   Set fsSearch = Application.FileSearch

   ‘ Настройка объекта для поиска

   With fsSearch

      ‘ Маска для поиска

      .LookIn = strFileName

      ‘ Путь для поиска

      .FileName = strPath

      ‘ Поиск всех файлов, удовлетворяющих маске

      .Execute

      ‘ Выход, если файлы не существуют

      If .FoundFiles.Count = 0 Then

         MsgBox «Файлы не обнаружены»

         Exit Sub

      End If

   End With

   ‘ Обработка найденных файлов

   For i = 1 To fsSearch.FoundFiles.Count

      Call ImportTextFile(fsSearch.FoundFiles(i))

   Next i

End Sub

Sub ImportTextFile(FileName As String)

   ‘ Импорт файла

   Workbooks.OpenText FileName:=FileName, _

    Origin:=xlWindows, _

    StartRow:=1, _

    DataType:=xlFixedWidth, _

    FieldInfo:= _

    Array(Array(0, 1), Array(3, 1), Array(12, 1))

   ‘ Ввод формул суммирования

   Range(«D1»).Value = «A»

   Range(«D2»).Value = «B»

   Range(«D3»).Value = «C»

   Range(«E1:E3»).Formula = «=COUNTIF(B:B,D1)»

   Range(«F1:F3»).Formula = «=SUMIF(B:B,D1,C:C)»

End Sub

Определение конца строки текстового файла

Sub Test()

   Open «file.txt» For Output As #1

   Print #1, «Hello , File»

   Close #1

   Open «file.txt» For Input As #1

   Dim s As String

   While Not EOF(1)

     Input #1, s

     MsgBox s

   Wend

   Close #1

End Sub

Копирование из текстового файла в эксель

Dim TextLine

i = 1

Open «C:MyFile.txt» For Input As #1

Do While Not EOF(1)

Line Input #1, TextLine

ThisWorkbook.Worksheets(«Лист1»).Cells(i, 1).Value = TextLine

i = i + 1

Loop

Close #1

Копирование содержимого в текстовый файл_1

Sub Range2TXT()

  MyFile = «C:File.txt» ‘путь к файлу

  Open MyFile For Output As #1 ‘открыли для записи

  For Each i In Selection ‘листаем ячейки выделенного диапазона

    Print #1, i ‘пишем (с начала)

  Next

  Close #1 ‘закрываем

End Sub

Копирование содержимого в текстовый файл_2

Sub SaveAsText()

   Dim cell As Range

   ‘ Открытие файла для сохранения (имя файла соответствует имени _

    рабочей книги, но отличается расширением — TXT)

   Open ThisWorkbook.Path & «» & ThisWorkbook.Name & «.txt» _

    For Output As #1

   ‘ Запись содержимого заполненных ячеек таблицы в файл

   For Each cell In ActiveSheet.UsedRange

      If Not IsEmpty(cell) Then

         Print #1, cell.Address, cell.Formula

      End If

   Next

   ‘ Не забываем закрывать файл

   Close #1

End Sub

Экспорт данных в txt

Sub ExportAsText()

   Dim lngRow As ****

   Dim intCol As Integer

   ‘ Открытие файла для сохранения

   Open «C:primer.txt» For Output As #1

   ‘ Запись выделенной части таблицы в файл (построчно)

   For lngRow = 1 To Selection.Rows.Count

      ‘ Запись содержимого всех столбцов строки lngRow

      For intCol = 1 To Selection.Columns.Count

         Write #1, Selection.Cells(lngRow, intCol).Value;

      Next intCol

      ‘ Начнем новую строку в файле

      Print #1, «»

   Next lngRow

   ‘ Не забываем закрыть файл

   Close #1

End Sub

Sub ImportText()

   Dim strLine As String         ‘ Одна строка файла

   Dim strCurChar As String * 1  ‘ Анализируемый символ строки файла

   Dim strValue As String        ‘ Значение для записи в ячейку

   Dim lngRow As ****            ‘ Номер текущей строки

   Dim intCol As Integer         ‘ Номер текущего столбца

   Dim i As Integer

   ‘ Открытие импортируемого файла

   Open «C:primer.txt» For Input As #1

   ‘ Считываем все строки файла и записываем данные, разделенные _

    запятой, в ячейки таблицы (начиная с текущей ячейки)

   Do Until EOF(1)

      ‘ Считываем строку из файла

      Line Input #1, strLine

      ‘ Разбираем считанную строку

      For i = 1 To Len(strLine)

         strCurChar = Mid(strLine, i, 1)

         If strCurChar = «,» Then

            ‘ Найден разделитель столбцов — запятая. Запишем _

             сформированное значение в ячейку

            ActiveCell.Offset(lngRow, intCol) = strValue

            intCol = intCol + 1

            strValue = «»

         ElseIf i = Len(strLine) Then

            ‘ Конец строки — запишем в таблицу последнее _

             значение в строке (перед этим дополним его последним _

             символом строки, кроме кавычки)

            If strCurChar <> Chr(34) Then

               strValue = strValue & strCurChar

            End If

            ‘ Запись в таблицу

            ActiveCell.Offset(lngRow, intCol) = strValue

            strValue = «»

         ElseIf strCurChar <> Chr(34) Then

            ‘ Добавление символа в формируемое значение ячейки _

             (кавычки игнорируются)

            strValue = strValue & strCurChar

         End If

      Next i

      ‘ Переход к новой строке таблицы

      intCol = 0

      lngRow = lngRow + 1

   Loop

   ‘ Закрываем файл

   Close #1

End Sub

Экспорт данных в HТМL

Sub ExportAsHТМLFile()

   Dim strStyle As String     ‘ Параметры стиля отображения ячейки

   Dim strAlign As String     ‘ Параметры выравнивания ячейки

   Dim strOut As String       ‘ Выходная строка с HТМL-кодом

   Dim cell As Object         ‘ Обрабатываемая ячейка

   Dim strCellText As String  ‘ Текст обрабатываемой ячейки

   Dim lngRow As ****         ‘ Номер строки обрабатываемой ячейки

   Dim lngLastRow As ****     ‘ Номер строки предыдущей ячейки

   Dim strTemp As String

   Dim strFileName As String  ‘ Имя файла для сохранения HТМL-кода

   Dim i As ****

   ‘ Запрос у пользователя имени файла для сохранения

   strFileName = Application.GetSaveAsFilename( _

    InitialFileName:=»Primer.htm», _

    fileFilter:=»HТМL Files(*.htm), *.htm»)

   ‘ Проверка, задал ли пользователь имя файла (если нет, _

    то можно выходить)

   If strFileName = «» Then Exit Sub

   lngLastRow = Selection.Row

   ‘ Просмотр всех выделенных ячеек

   For Each cell In Selection

      ‘ Значение строки для рассматриваемой ячейки

      lngRow = cell.Row

      ‘ Если перешли на другую строку, то вставляем <tr>

      If lngRow <> lngLastRow Then

         strOut = strOut & vbTab & «</tr>» & vbCrLf & vbTab & _

          «<tr>» & vbCrLf

         ‘ Переход на следующую сроку

         lngLastRow = lngRow

      End If

      ‘ Задание шрифта ячейки

      If Not IsNull(cell.Font.Size) Then

         strStyle = » style=» & «font-size: » & Int(100 * _

          cell.Font.Size / 19) & «%;»

      End If

      ‘ Для полужирного шрифта вставляем <b>

      If cell.Font.Bold Then

         strCellText = «<b>» & strCellText & «</b>»

      End If

      ‘ Задание выравнивания

      If cell.HorizontalAlignment = xlRight Then

         ‘ По правому краю

         strAlign = » align=» & «right»

      ElseIf cell.HorizontalAlignment = xlCenter Then

         ‘ По центру

         strAlign = » align=» & «center»

      Else

         ‘ По левому краю (по умолчанию)

         strAlign = «»

      End If

      ‘ Чтение текста в ячейке

      strCellText = cell.Text

      ‘ Если нужно, то вертикальный вывод текста (в строку strTemp _

       с последующим перенесением обратно в strCellText)

      If cell.Orientation <> xlHorizontal Then

         strTemp = «»

         ‘ Печать после каждого символа специального _

          разделителя — <br>

         For i = 1 To Len(strCellText)

            strTemp = strTemp & Mid$(strCellText, i, 1) & «<br>»

         Next i

         strCellText = strTemp

         strStyle = «»

      End If

      strOut = strOut & vbTab & vbTab & «<td» & strStyle & _

       strAlign & «>» & strCellText & «</td>» & vbCrLf

   Next

   ‘ Вставка <tr> для первой строки и </tr> — для последней

   strOut = vbTab & «<tr>» & vbCrLf & strOut & vbTab & «</tr>» & vbCrLf

   ‘ Вставка дескриптора <table>

   strOut = «<table border=1 cellpadding=3 cellspacing=1>» _

    & vbCrLf & strOut & vbCrLf & «</table>»

   ‘ Сохранение HТМL-кода в файл

   Open strFileName For Output As 1

   Print #1, strOut

   Close 1

   ‘ Вывод окна с информационным сообщением о результатах работы

   MsgBox Selection.Count & » ячеек экспортировано в файл » & _

    strFileName

End Sub

Импорт данных, для которых нужно более 256 столбцов

Sub ImportWideSheet()

   Dim rgRange As Range              ‘ Хранит заполняемую ячейку

   Dim lngRow As ****                ‘ Хранит номер текущей строки

   Dim intCol As Integer             ‘ Хранит номер текущего столбца

   Dim i As Integer

   Dim strLine As String             ‘ Обрабатываемая строка (из файла)

   Dim strCurChar As String * 1

   Dim strCellValue As String        ‘ В этой строке формируется значение _

                                       заполняемой ячейки таблицы

   Dim wshtCurrentSheet As Worksheet ‘ Лист, на котором находится _

                                       заполняемая ячейка

   ‘ Отключение обновления изображения

   Application.ScreenUpdating = False

   ‘ Создание книги с одним листом

   Workbooks.Add xlWorksheet

   Set rgRange = ActiveWorkbook.Sheets(1).Range(«A1»)

   ‘ Чтение первой строки из файла (по этой строке определяется _

    ширина таблицы)

    Open ThisWorkbook.Path & «Primer.txt» For Input As #1

   Line Input #1, strLine

   ‘ Обработка первой строки с добавлением новых листов по мере _

    необходимости

   For i = 1 To Len(strLine)

      strCurChar = Mid(strLine, i, 1)

      ‘ Проверка — закончились столбцы или нет

      If intCol <> 0 And intCol Mod 256 = 0 Then

         ‘ Столбцы текущего листа закончились — добавим новый лист _

          и перейдем к его первому столбцу

         Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

          ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

         Set rgRange = wshtCurrentSheet.Range(«A1»)

         intCol = 0

      End If

      ‘ Проверка — закончилось поле или нет

      If strCurChar = «,» Then

         ‘ Запишем данные в таблицу

         rgRange.Offset(lngRow, intCol) = strCellValue

         intCol = intCol + 1

         strCellValue = «»

      Else

         ‘ Добавляем очередной символ в строку со значением текущей _

          ячейки

         strCellValue = strCellValue & Mid(strLine, i, 1)

         ‘ Проверка — конец строки или нет

         If i = Len(strLine) Then

            ‘ Дошли до конца строки — запишем значение последней ячейки

            rgRange.Offset(lngRow, intCol) = strCellValue

            intCol = 0

            strCellValue = «»

         End If

      End If

   Next i

   ‘ Чтение остальных строк файла

   Do Until EOF(1)

      Set rgRange = ActiveWorkbook.Sheets(1).Range(«A1»)

      lngRow = lngRow + 1

      intCol = 0

      Line Input #1, strLine

      ‘ Обработка считанной строки

      For i = 1 To Len(strLine)

         strCurChar = Mid(strLine, i, 1)

         ‘ Проверка — закончились столбцы или нет

         If intCol <> 0 And intCol Mod 256 = 0 Then

            ‘ Столбцы текущего листа закончились — добавим новый лист _

             и перейдем к его первому столбцу

            Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

             ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

            Set rgRange = wshtCurrentSheet.Range(«A1»)

            intCol = 0

         End If

         ‘ Проверка — закончилось поле или нет

         If strCurChar = «,» Then

            ‘ Запишем данные в таблицу

            rgRange.Offset(lngRow, intCol) = strCellValue

            intCol = intCol + 1

            strCellValue = «»

         Else

            ‘ Добавляем очередной символ в строку со значением текущей _

             ячейки

            strCellValue = strCellValue & Mid(strLine, i, 1)

            ‘ Проверка — конец строки или нет

            If i = Len(strLine) Then

               ‘ Дошли до конца строки — запишем значение последней _

                ячейки

               rgRange.Offset(lngRow, intCol) = strCellValue

               strCellValue = «»

            End If

         End If

      Next i

   Loop

   ‘ Не забываем закрыть входной файл

   Close #1

   ‘ и разрешить обновление изображения

   Application.ScreenUpdating = True

End Sub

Создание резервных копий ценных файлов

 Этот макрос сохраняет текущую книгу в папку C:TEMP, добавляя к имени книги текущее время и дату.

Sub Backup_Active_Workbook()

    Dim x As String

    strPath = «c:TEMP»

    On Error Resume Next

    x = GetAttr(strPath) And 0

    If Err = 0 Then ‘ если путь существует — сохраняем копию книги

        strDate = Format(Now, «dd/mm/yy hh-mm»)

        FileNameXls = strPath & «» & Left(ActiveWorkbook.Name,  _

             Len(ActiveWorkbook.Name) — 4) & » » & strDate & «.xls»

        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls

    Else ‘если путь не существует — выводим сообщение

        MsgBox «Папка » & strPath & » недоступна или не существует!», vbCritical

    End If

End Sub

При желании можно заменить первую строку на:

Private Sub Workbook_BeforeClose(Cancel As Boolean)

и поместить этот макрос не в Module1 как обычно, а в модуль ЭтаКнига (ThisWorkbook) — тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла.

Подсчет количества открытий файла

Количество открытий файла (вариант 1)

Sub Auto_Open()

   Worksheets(1).Cells(1) = Worksheets(1).Cells(1) + 1

End Sub

Количество открытий файла (вариант 2)

Sub Auto_Open()

   Worksheets(1).Cells(1, 1) = Worksheets(1).Cells(1, 1) + 1

End Sub

Количество открытий файла (вариант 3)

Sub Auto_Open()

   Worksheets(1).Range(«A1») = Worksheets(1).Range(«A1») + 1

End Sub

Вывод пути к файлу в активную ячейку

Sub ExcelSearch()

Dim fname As String

Dim result As Integer

With Application.FileDialog(1) ‘ ?????? : With Application.FileDialog(msoFileDialogOpen) ‘

.Title = «Select Excel file»

.InitialFileName = «C:» ‘default path’

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add «Pack files», «*.xls», 1

result = .Show

If result = 0 Then Exit Sub

fname = Trim(.SelectedItems.Item(1))

End With

‘On Error Resume Next

ActiveCell = fname

End Sub

Копирование содержимого файла RTF в эксель

Sub OpenRtfAndPasteToSheets()

Dim wd As Object

Dim ns As Worksheet

On Error Resume Next

‘запустим Ворд

Set wd = GetObject(«», «Word.Application»)

If Err.Number <> 0 Then

Err.Clear

Set wd = CreateObject(«Word.Application»)

If Err.Number <> 0 Then Exit Sub

End If

On Error GoTo BAD

Do

‘получим имя очередного файла

f = Application.GetOpenFilename(«Файлы RTF, *.rtf,Все файлы, *.*»)

If TypeName(f) = «Boolean» Then Exit Do ‘если Отмена — выход

‘откроем выбранный очередной файл

Set wdd = wd.Documents.Open(f)

‘ wd.Visible = True

‘скопируем содержимое документа

t = wdd.Content.Copy

‘создадим лист для этого документа

Set ns = ActiveWorkbook.Worksheets.Add

‘вставим скопированное в новый лист

ns.Paste Destination:=ns.Cells(1, 1)

‘немного выравним вид

ns.Cells.WrapText = False

ns.Columns.AutoFit

ns.Rows.AutoFit

wdd.Close

Loop

wd.Quit

Set wd = Nothing

Exit Sub

BAD:

MsgBox Err.Desсriрtion

On Error Resume Next

wd.Quit

Set wd = Nothing

End

End Sub

Копирование данных из закрытой книги

ActiveCell.FormulaR1C1 = «=’D:contactszakaz[zakaz.xls]Лист1′!R1C1»

Извлечение данных из закрытого файла

Sub GetDataFromFile()

   Range(«A1»).Formula = «=’C:[Example.xls]Лист1′!A1»

End Sub

Поиск слова в файлах

Option Explicit

Sub Поиск_во_всех_файлах()

Dim iShtName$, iPath$, iFileName$, firstAddress$

Dim iSheet As Worksheet, iFoundSht As Worksheet

Dim iTempWB As Workbook, iBazaWB As Workbook

Dim TextToFind As Variant, iFoundRng As Range

Dim FD As FileDialog, iLastRow&

Dim FoundAny As Boolean

    TextToFind = Application.InputBox(«Введите текст для поиска:», «Поиск»)

    If TextToFind = «» Or TextToFind = False Then Exit Sub

    TextToFind = Trim(TextToFind)

    Set FD = Application.FileDialog(msoFileDialogFilePicker)

    With FD

        .AllowMultiSelect = False

        .Title = «Укажите любой файл в папке»

        .ButtonName = «Выбрать папку»

        If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), «»))

    End With

    Set FD = Nothing

    Workbooks.Add

    Sheets.Add.Name = «Поиск»

    Set iFoundSht = ActiveSheet

    iFoundSht.Cells(1, 1) = «Ищем: » & TextToFind

    iFoundSht.Cells(1, 1).Font.Bold = True

    With Application

        .ScreenUpdating = False

        .Calculation = xlManual

        .StatusBar = «Идёт поиск…»

        .ShowWindowsInTaskbar = False

        iFileName = Dir(iPath & «*.xls»)

        Do While iFileName$ <> «»

            Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, updаtеLinks:=False, ReadOnly:=True)

            For Each iSheet In iTempWB.Sheets

                If iSheet.FilterMode = True Then iSheet.ShowAllData

                Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)

                If Not iFoundRng Is Nothing Then

                    FoundAny = True

                    firstAddress = iFoundRng.Address

                    Do

                        With iFoundSht

                            iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

                            If iLastRow = 1 Then iLastRow = 2

                            If iShtName <> iSheet.Name Then    ‘если новый файл

                                With .Cells(iLastRow + 2, 1)

                                    .Value = «Файл: » & iTempWB.Name & «, Лист: » & iSheet.Name

                                    .Font.Bold = True

                                End With

                            End If

                            iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)    ‘копируем всю строку

                            iShtName = iSheet.Name

                        End With

                        Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)

                    Loop While iFoundRng.Address <> firstAddress

                Else

                End If

            Next

            iTempWB.Close SaveChanges:=False

            iFileName = Dir

        Loop

        .StatusBar = False

        .ShowWindowsInTaskbar = True

        .EnableEvents = True

        .Calculation = xlCalculationAutomatic

        .ScreenUpdating = True

    End With

    If FoundAny = False Then

        MsgBox «Текст ‘» & TextToFind & «‘ ни в одном из файлов в папке:» & Chr(10) & iPath & Chr(10) & » не был найден!», 48, «Отчёт»

        iFoundSht.Parent.Close SaveChanges:=False

        Exit Sub

    End If

    MsgBox «Поиск » & TextToFind & » завершён!», 64, «Поиск»

End Sub

Создание текстового файла и ввод текста в файл

Sub Test()

 Open «c:2.txt» For Output As #1

 Print #1, «Hello File»

 Close #1

 Open «c:1.txt» For Input As #1

 Dim s As String

 Input #1, s

 MsgBox s

 Close #1

End Sub

Создание текстового файла и ввод текста (определение конца файла)

Sub Test()

Open «c:1.txt» For Output As #1

 Print #1, «Hello , File»

Close #1

Open «c:1.txt» For Input As #1

 Dim s As String

 While Not EOF(1)

  Input #1, s

  MsgBox s

 Wend

Close #1

End Sub

Создание документов Word на основе таблицы Excel

Sub ReportToWord()

   Dim intReportCount As Integer  ‘ Количество сообщений

   Dim strForWho As String        ‘ Получатель сообщения

   Dim strSum As String           ‘ Сумма за товар

   Dim strProduct As String       ‘ Название товара

   Dim strOutFileName As String   ‘ Имя файла для сохранения сообщения

   Dim strMessage As String       ‘ Текст дополнительного сообщения

   Dim rgData As Range            ‘ Обрабатываемые ячейки

   Dim objWord As Object

   Dim i As Integer

   ‘ Создание объекта Word

   Set objWord = CreateObject(«Word.Application»)

   ‘ Информация с рабочего листа

   Set rgData = Range(«A1»)

   strMessage = Range(«E6»)

   ‘ Просмотр записей на листе Лист1

   intReportCount = Application.CountA(Range(«A:A»))

   For i = 1 To intReportCount

      ‘ Динамические сообщения в строке состояния

      Application.StatusBar = «Создание сообщения » & i

      ‘ Назначение данных переменным

      strForWho = rgData.Cells(i, 1).Value

      strProduct = rgData.Cells(i, 2).Value

      strSum = Format(rgData.Cells(i, 3).Value, «#,000»)

      ‘ Имя файла для сохранения отчета

      strOutFileName = ThisWorkbook.path & «» & strForWho & «.doc»

      ‘ Передача команд в Word

      With objWord

         .Documents.Add

         With .Selection

            ‘ Заголовок сообщения

            .Font.Size = 14

            .Font.Bold = True

            .ParagraphFormat.Alignment = 1

            .TypeText Text:=»О Т Ч Е Т»

            ‘ Дата

            .TypeParagraph

            .TypeParagraph

            .Font.Size = 12

            .ParagraphFormat.Alignment = 0

            .Font.Bold = False

            .TypeText Text:=»Дата:» & vbTab & _

             Format(Date, «mmmm d, yyyy»)

            ‘ Получатель сообщения

            .TypeParagraph

            .TypeText Text:=»Кому: менеджеру » & vbTab & strForWho

            ‘ Отправитель

            .TypeParagraph

            .TypeText Text:=»От:» & vbTab & Application.UserName

            ‘ Сообщение

            .TypeParagraph

            .TypeParagraph

            .TypeText strMessage

            .TypeParagraph

            .TypeParagraph

            ‘ Название товара

            .TypeText Text:=»Продано товара:» & vbTab & strProduct

            .TypeParagraph

            ‘ Сумма за товар

            .TypeText Text:=»На сумму:» & vbTab & _

             Format(strSum, «$#,##0»)

         End With

         ‘ Сохранение документа

         .ActiveDocument.SaveAs FileName:=strOutFileName

      End With

   Next i

   ‘ Удаление объекта Word

   objWord.Quit

   Set objWord = Nothing

   ‘ Обновление строки состояния

   Application.StatusBar = False

   ‘ Вывод на экран информационного сообщения

   MsgBox intReportCount & » заметки создано и сохранено в папке » _

    & ThisWorkbook.path

End Sub

Команды создания и удаления каталогов

Sub Test()

 MkDir («c:test»)

End Sub

И удаляем.

Sub Test()

 RmDir («c:test»)

End Sub

Получение  текущего каталога

Sub Test()

 MsgBox (CurDir)

End Sub

Смена каталога

Sub Test()

 ChDir («c:windows»)

 MsgBox (CurDir)

End Sub

Посмотреть все файлы в каталоге_1

Sub Test()

 Dim s As String

 s = Dir(«c:windowsinf*.*»)

 Debug.Print s

 Do While s <> «»

   s = Dir

   Debug.Print s

 Loop

End Sub

Посмотреть все файлы в каталоге_2

‘ Объявление API-функции для отображения стандартного окна _

 просмотра папок

Declare Function SHBrowseForFolder Lib «shell32.dll» _

 Alias «SHBrowseForFolderA» (lpBrowseInfo As BROWSEINFO) As ****

‘ Объявление API-функции для преобразования данных, возвращаемых _

 функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib «shell32.dll» _

 Alias «SHGetPathFromIDListA» (ByVal pidl As ****, ByVal _

 pszPath As String) As ****

‘ Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

   hwndOwner As ****     ‘ Родительское окно (для диалога)

   pidlRoot As ****      ‘ Корневая папка для просмотра

   strDisplayName As String

   strTitle As String    ‘ Заголовок окна

   ulFlags As ****       ‘ Флаги для окна

   ‘ Следующие три параметра в VBA не используются

   lpfn As ****

   lParam As ****

   iImage As ****

End Type

Sub BrowseFolder()

   Dim strPath As String  ‘ Папка, список файлов которой выводится

   Dim strFile As String

   Dim intRow As ****     ‘ Текущая строка таблицы

   ‘ Выбор папки

   strPath = dhBrowseForFolder()

   If strPath = «» Then Exit Sub

   If Right(strPath, 1) <> «» Then strPath = strPath & «»

   ‘ Оформление заголовка отчета

   ActiveSheet.Cells.ClearContents

   ActiveSheet.Cells(1, 1) = «Имя файла»

   ActiveSheet.Cells(1, 2) = «Размер»

   ActiveSheet.Cells(1, 3) = «Дата/время»

   ActiveSheet.Range(«A1:C1»).Font.Bold = True

   ‘ Просмотр объектов в папке…

   ‘ Первый объект папки

   strFile = Dir(strPath, 7)

   intRow = 2

   Do While strFile <> «»

      ‘ Запись в столбец «A» имени файла

      ActiveSheet.Cells(intRow, 1) = strFile

      ‘ Запись в столбец «B» размера файла

      ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

      ‘ Запись в столбец «C» времени изменения файла

      ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

      ‘ Следующий объект папки

      strFile = Dir

      intRow = intRow + 1

   Loop

End Sub

Function dhBrowseForFolder() As String

   Dim biBrowse As BROWSEINFO

   Dim strPath As String

   Dim lngResult As ****

   Dim intLen As Integer

   ‘ Заполнение полей структуры BROWSEINFO

   ‘ Корневая папка — Рабочий стол

   biBrowse.pidlRoot = 0&

   ‘ Заголовок окна

   biBrowse.strTitle = «Выбор папки»

   ‘ Тип возвращаемой папки

   biBrowse.ulFlags = &H1

   ‘ Вывод стандартного окна просмотра папок

   lngResult = SHBrowseForFolder(biBrowse)

   ‘ Обработка результата работы окна

   If lngResult Then

      ‘ Получение пути (по возвращенным данным)

      strPath = Space$(512)

      If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

         ‘ Строка пути заканчивается символом Chr(0)

         intLen = InStr(strPath, Chr$(0))

         ‘ Выделение и возврат пути

         dhBrowseForFolder = Left(strPath, intLen — 1)

      Else

         ‘ Не удалось получить путь

         dhBrowseForFolder = «»

      End If

   Else

      ‘ Пользователь нажал кнопку «Отмена»

      dhBrowseForFolder = «»

   End If

End Function

Посмотреть все файлы в каталоге_3

‘ Объявление API-функции для отображения стандартного окна _

 просмотра папок

Declare Function SHBrowseForFolder Lib «shell32.dll» _

 Alias «SHBrowseForFolderA» (lpBrowseInfo As BROWSEINFO) As ****

‘ Объявление API-функции для преобразования данных, возвращаемых _

 функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib «shell32.dll» _

 Alias «SHGetPathFromIDListA» (ByVal pidl As ****, ByVal _

 pszPath As String) As ****

‘ Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

   hwndOwner As ****     ‘ Родительское окно (для диалога)

   pidlRoot As ****      ‘ Корневая папка для просмотра

   strDisplayName As String

   strTitle As String    ‘ Заголовок окна

   ulFlags As ****       ‘ Флаги для окна

   ‘ Следующие три параметра в VBA не используются

   lpfn As ****

   lParam As ****

   iImage As ****

End Type

Sub BrowseFolder1()

   Dim strPath As String  ‘ Папка, список файлов которой выводится

   Dim strFile As String

   Dim intRow As ****     ‘ Текущая строка таблицы

   ‘ Выбор папки

   strPath = dhBrowseForFolder()

   If strPath = «» Then Exit Sub

   If Right(strPath, 1) <> «» Then strPath = strPath & «»

   ‘ Оформление заголовка отчета

   ActiveSheet.Cells.ClearContents

   ActiveSheet.Cells(1, 1) = «Имя файла»

   ActiveSheet.Cells(1, 2) = «Размер»

   ActiveSheet.Cells(1, 3) = «Дата/время»

   ActiveSheet.Range(«A1:C1»).Font.Bold = True

   ‘ Просмотр объектов в папке…

   ‘ Первый объект папки

   strFile = Dir(strPath, 7)

   intRow = 2

   Do While strFile <> «»

      ‘ Запись в столбец «A» имени файла

      ActiveSheet.Cells(intRow, 1) = strPath & strFile

      ‘ Запись в столбец «B» размера файла

      ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

      ‘ Запись в столбец «C» времени изменения файла

      ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

      ‘ Следующий объект папки

      strFile = Dir

      intRow = intRow + 1

   Loop

End Sub

Function dhBrowseForFolder() As String

   Dim biBrowse As BROWSEINFO

   Dim strPath As String

   Dim lngResult As ****

   Dim intLen As Integer

   ‘ Заполнение полей структуры BROWSEINFO

   ‘ Корневая папка — Рабочий стол

   biBrowse.pidlRoot = 0&

   ‘ Заголовок окна

   biBrowse.strTitle = «Выбор папки»

   ‘ Тип возвращаемой папки

   biBrowse.ulFlags = &H1

   ‘ Выводим стандартное окно просмотра папок

   lngResult = SHBrowseForFolder(biBrowse)

   ‘ Обработка результата работы окна

   If lngResult Then

      ‘ Получение пути (по возвращенным данным)

      strPath = Space$(512)

      If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

         ‘ Строка пути заканчивается символом Chr(0)

         intLen = InStr(strPath, Chr$(0))

         ‘ Выделение и возврат пути

         dhBrowseForFolder = Left(strPath, intLen — 1)

      Else

         ‘ Не удалось получить путь

         dhBrowseForFolder = «»

      End If

   Else

      ‘ Пользователь нажал кнопку «Отмена» в окне

      dhBrowseForFolder = «»

   End If

End Function

ГЛАВА 3. РАБОЧАЯ ОБЛАСТЬ MICROSOFT EXCEL

Рабочая книга

Количество имен рабочей книги

Sub CountNames()

   Dim intNamesCount As Integer

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

    листе рабочей книги

   intNamesCount = Names.Count

   If intNamesCount = 0 Then

      MsgBox «Имен нет»

   Else

      MsgBox «Имен: » & intNamesCount & » шт.»

   End If

End Sub

Защита рабочей книги

Sub Worksheet_BeforeRightClick(ByVal Target As Range, _

 Cancel As Boolean)

   If Target.Address = «$D$2» Then

      ‘ Установка защиты рабочей книги (с паролем «123», _

       включенной защитой структуры книги и защитой расположения _

       окон)

      ThisWorkbook.Protect «123», True, True

      ‘ Указание не обрабатывать нажатие кнопки мыши _

       в этой ячейке

      Cancel = True

   ElseIf Target.Address = «$E$5» Then

      ‘ Снятие защиты с книги (необходимо указать ранее установленный _

       пароль)

      ThisWorkbook.Unprotect «123»

      Cancel = True

   End If

End Sub

Запрет печати книги

Sub Workbook_BeforePrint(Cancel As Boolean)

   ‘ Установка флага в True заставляет Exсel игнорировать команду _

    отправки книги на печать

   Cancel = True

End Sub

Открытие книги (или текстовых файлов)

Sub Test()

 Application.Workbooks.Open («c:file_03.txt»)

End Sub

Открытие книги и добавление в ячейку А1 текста

Dim Ex As New Excel.Application

Ex.Workbooks.Open «Путь к Файлу»

Ex.Visible = False

‘В ячейку «A2» добавляем «Visual Basic»

Ex.ActiveWorkbook.Sheets.Application.Range(«A2») = «Visual Basic»

Ex.ActiveWorkbook.Save

Ex.ActiveWorkbook.Close

Сколько книг открыто

Sub Test()

 MsgBox (Str(Application.Workbooks.Count))

End Sub

Закрытие всех книг

Sub Test()

 Application.Workbooks.Item(1).Close  ‘(еxprеssion.Close(SaveChanges, FileName, RouteWorkbook)

End Sub

Закрытие рабочей книги только при выполнении условия

Sub Workbook_BeforeClose(Cancel As Boolean)

   If Range(«A1»).Value <> «Можно закрывать» Then

      ‘ Условие закрытия не выполнено. Укажем Exсel игнорировать _

       команду

      Cancel = True

   End If

End Sub

Сохранение рабочей книги с именем, представляющим собой текущую дату

Sub SaveAsDate()

   Dim strDate As String

   ‘ Получение текущей даты и представление ее в формате «ддммгг»

   strDate = Format(Now(), «ddmmyy»)

   ‘ Сохранение книги в текущую папку под новым именем

   ActiveWorkbook.SaveAs ActiveWorkbook.Path & «» & strDate

End Sub

Сохранена ли рабочая книга

Function dhBookIsSaved() As Boolean

   ‘ Если путь файла рабочей книги не задан, то она _

    не сохранена (ThisWorkbook.path равняется «»)

   dhBookIsSaved = ThisWorkbook.path <> «»

End Function

Создать книгу с одним листом

Sub NewOneSheetBook()

   Workbooks.Add xlWBATWorksheet

End Sub

Создать книгу

Sub Test()

 Application.Workbooks.Add («Êíèãà»)

End Sub

Удаление ненужных имен

Sub EraseNames()

   Dim nmName As Name

   Dim strMessage As String

   ‘ Проверка наличия в книге определенных имен

   If ThisWorkbook.Names.Count = 0 Then

      ‘ В книге нет определенных имен

      MsgBox «Имена не определены»

      Exit Sub

   End If

   ‘ Просмотр всей коллекции определенных имен и удаление тех, _

    которые пользователю не нужны

   For Each nmName In ThisWorkbook.Names

      With nmName

         ‘ Спрашиваем пользователя о необходимости удалить _

          найденное имя

         strMessage = «Удалить имя » & .Name & » ? » & vbCr & _

          «относящееся к » & .RefersTo

         If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then

            ‘ Имя можно удалить

            .Delete

         End If

      End With

   Next

End Sub

Быстрое размножение рабочей книги

Sub DuplicateBook()

   Dim avarFileNames As Variant

   ‘ Формирование массива из путей для копий книги

   avarFileNames = Array(«C:» & _

   ActiveWorkbook.Name, «D:» & ActiveWorkbook.Name)

   ‘ Сохранение книги

   ActiveWorkbook.SaveAs avarFileNames

End Sub

Сортировка листов

Sub SortSheets()

    Dim astrSheetNames() As String ‘ Массив для хранения имен листов

    Dim intSheetCount As Integer

    Dim i As Integer

    Dim objActiveSheet As Object

    ‘ Если нет активной рабочей книги — закрыть процедуру

    If ActiveWorkbook Is Nothing Then Exit Sub

    ‘ Проверка защищенности структуры рабочей книги

    If ActiveWorkbook.ProtectStructure Then

        ‘ Сортировка листов защищенной рабочей книги невозможна

        MsgBox «Структура книги » & ActiveWorkbook.Name & _

         » защищена. Сортировка листов невозможна.», _

         vbCritical

        Exit Sub

    End If

    ‘ Сохраняем ссылку на активный лист книги

    Set objActiveSheet = ActiveSheet

    ‘ Отключение сочетания клавиш Ctrl+Pause Break

    Application.EnableCancelKey = xlDisabled

    ‘ Отключение обновления экрана

    Application.ScreenUpdating = False

    intSheetCount = ActiveWorkbook.Sheets.Count

    ‘ Заполнение массива astrSheetNames именами листов книги

    ReDim astrSheetNames(1 To intSheetCount)

    For i = 1 To intSheetCount

        astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name

    Next i

    ‘ Сортировка массива имен в порядке возрастания

    Call Sort(astrSheetNames)

    ‘ Перемещение листов книги

    For i = 1 To intSheetCount

        ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

         ActiveWorkbook.Sheets(i)

    Next i

    ‘ Переход на исходный рабочий лист

    objActiveSheet.Activate

    ‘ Включение обновления экрана

    Application.ScreenUpdating = True

    ‘ Включение сочетания клавиш Ctrl+Pause Break

    Application.EnableCancelKey = xlInterrupt

End Sub

Sub Sort(astrNames() As String)

    ‘ Сортировка массива строк по алфавиту (в порядке возрастания)

    Dim i As Integer, j As Integer

    Dim strBuffer As String

    Dim fBuffer As Boolean

    For i = LBound(astrNames) To UBound(astrNames) — 1

        For j = i + 1 To UBound(astrNames)

            If astrNames(i) > astrNames(j) Then

                ‘ Меняем i-й и j-й элементы массива местами

                strBuffer = astrNames(i)

                astrNames(i) = astrNames(j)

                astrNames(j) = strBuffer

            End If

        Next j

    Next i

End Sub

Поиск максимального значения на всех листах книги

Function dhMaxInBook(cell As Range) As Double

   Dim sheet As Worksheet

   Dim dblMax As Double

   Dim dblResult As Double

   Dim fFirst As Boolean

   fFirst = True

   ‘ Расчет максимальных значений на всех листах рабочей книги _

    и выбор наибольшего из них

   For Each sheet In cell.Parent.Parent.Worksheets

      ‘ Расчет максимального значения на листе

      dblResult = Application.WorksheetFunction.Max(sheet.UsedRange)

      If fFirst Then

         ‘ Найдено первое значение — его не с чем сравнивать

         dblMax = dblResult

         fFirst = False

      End If

      ‘ Выбираем большее из dblMax и dbmResult

      If dblResult > dblMax Then

         dblMax = dblResult

      End If

   Next sheet

   ‘ Возврат результата

   dhMaxInBook = dblMax

End Function

РАБОЧИЙ ЛИСТ

Проверка наличия защиты рабочего листа

Sub IsSheetProtected()

   ‘ Проверка, установлена ли защита на содержимое листа

   If Worksheets(1).ProtectContents Then

      MsgBox «Защита листа включена»

   Else

      MsgBox «Защита листа не включена»

   End If

End Sub

Список отсортированных листов

Sub SortSheets2()

   Dim astrSheetNames() As String ‘ Массив для хранения имен листов

   Dim intSheetCount As Integer

   Dim i As Integer

   Dim objActiveSheet As Object

   ‘ Если нет активной рабочей книги — закрыть процедуру

   If ActiveWorkbook Is Nothing Then Exit Sub

   ‘ Проверка защищенности структуры рабочей книги

   If ActiveWorkbook.ProtectStructure Then

      ‘ Сортировка листов защищенной рабочей книги невозможна

      MsgBox «Структура книги » & ActiveWorkbook.Name & _

       » защищена. Сортировка листов невозможна.», _

       vbCritical

      Exit Sub

   End If

   ‘ Сохраняем ссылку на активный лист книги

   Set objActiveSheet = ActiveSheet

   ‘ Отключение сочетания клавиш Ctrl+Pause Break

   Application.EnableCancelKey = xlDisabled

   ‘ Функция обновления экрана отключается

   Application.ScreenUpdating = False

   With ActiveWorkbook

      ‘ Cоздаем новый лист «Сортировка» (если он еще не создан)

      On Error Resume Next

      If .Sheets(«Сортировка») Is Nothing Then

         .Sheets.Add.Name = «Сортировка»

      End If

      On Error GoTo 0

      ‘ Размещение данных на листе «Сортировка» (в столбец «A»)

      intSheetCount = .Sheets.Count

      For i = 1 To intSheetCount

         .Sheets(«Сортировка»).Cells(i, 1) = .Sheets(i).Name

      Next i

      ‘ Сортировка данных в ячейках листа «Сортировка» по содержимому _

       столбца A

      .Sheets(«Сортировка»).Range(«A1»).Sort _

       Key1:=.Sheets(«Сортировка»).Range(«A1»), _

       Order1:=xlAscending

      ‘ Заполнение массива имен отсортированными строками

      ReDim astrSheetNames(1 To intSheetCount)

      For i = 1 To intSheetCount

         astrSheetNames(i) = .Sheets(«Сортировка»).Cells(i, 1)

      Next i

      ‘ Перемещение листов

      For i = 1 To intSheetCount

         .Sheets(astrSheetNames(i)).Move .Sheets(i)

      Next i

   End With

   ‘ Переход на исходный рабочий лист

   objActiveSheet.Activate

   ‘ Включаем обновление экрана

   Application.ScreenUpdating = True

   ‘ Включение сочетания клавиш Ctrl+Pause Break

   Application.EnableCancelKey = xlInterrupt

End Sub

Создать новый лист_1

Sub NewSheet()

   Worksheets.Add

End Sub

‘Sub Tes2t()

‘With Application.Workbooks.Item(ActiveWorkbook.Name)

 ‘Sheets.Add

 ‘End With

‘End Sub

‘Dim ExNew As Worksheet

 ‘Set ExNew = ActiveWorkbook.Worksheets.Add

‘ExNew.Name = «Имя Листа»

Создать новый лист_2

Worksheets.Add.Name = «List12345.xls»

Удаление листов в зависимости от даты

‘ Function DelSheetByDate

‘ Удаляет рабочий лист sSheetName в активной рабочей книге,

‘ если дата dDelDate уже наступила

‘ В случае успеха возвращает True, иначе — False

Public Function DelSheetByDate(sSheetName As String, _

                               dDelDate As Date) As Boolean

On Error GoTo errHandle

  DelSheetByDate = False

  ‘ Проверка даты

  If dDelDate <= Date Then

   ‘ Не выводить подтверждение на удаление

   Application.DisplayAlerts = False

   ActiveWorkbook.Worksheets(sSheetName).Delete

   DelSheetByDate = True

   Application.DisplayAlerts = True

 End If

Exit Function

errHandle:

  MsgBox Err.Desсriрtion, vbCritical, «Ошибка №» & Err.Number

End Function

Копирование листа в книге

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

 Sheets(«Test»).Copy , after:=Sheets(«Лист3»)

 End With

End Sub

Копирование листа в новую книгу (создается)

Sub Test()

  With Application.Workbooks.Item(«Test.xls»)

  Sheets(«Test»).Copy

  End With

End Sub

Перемещение листа в книге

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

 Sheets(«Test»).Move , after:=Sheets(«Лист3»)

 End With

End Sub

Перемещение нескольких листов в новую книгу

Sheets(Array(«Лист1», «Лист2», «Лист3»)).Select

Sheets(«Лист3»).Activate

Sheets(Array(«Лист1», «Лист2», «Лист3»)).Copy

Заменить существующий файл

Sub copy_sheet()

ShName = ActiveSheet.Name

Sheets(ShName).Copy

ActiveWorkbook.SaveAs «c:» & ShName & «.xls»

End Sub

Чтобы не вылезало диалоговое окно надо добавить

Application.DisplayAlerts = False ‘ вылючаем все предупреждения

ActiveWorkbook.SaveAs «c:» & ShName & «.xls»

Application.DisplayAlerts = True ‘обратно включаем предупреждения.

«Перелистывание» книги

Sub SheetsOfBook()

   Dim sheet As Object

   ‘ Отображение имен всех листов активной рабочей книги

   For Each sheet In ActiveWorkbook.Sheets

      MsgBox (sheet.Name)

   Next

End Sub

Вставка колонтитула с именем книги, листа и текущей датой

Sub AddPageHeader()

   Dim i As Integer

   With ThisWorkbook

      ‘ Вставка колонтитулов на все листы рабочей книги

      For i = 1 To .Worksheets.Count — 1

         .Worksheets(i).PageSetup.LeftHeader = .FullName

         .Worksheets(i).PageSetup.CenterHeader = Worksheets(i).Name

         .Worksheets(i).PageSetup.RightHeader = Now()

      Next

   End With

End Sub

Существует ли лист

Function dhSheetExist(strSheetName As String) As Boolean

   Dim objSheet As Object

   On Error GoTo HandleError ‘ При ошибке перейти на HandleError

   ‘ Пытаемся получить ссылку на заданный лист

   objSheet = ActiveWorkbook.Sheets(strSheetName)

   ‘ Ошибки не возникло — лист существует

   dhSheetExist = True

   Exit Function

HandleError:

   ‘ При попытке получить доступ к листу с заданным именем _

    возникла ошибка, значит, такого листа не существует

   dhSheetExist = False

End Function

Существует ли лист_2

   L = 0

For Each Sheet In Worksheets

If Sheet.Name = «List12» Then

L = 1

MsgBox «List12 совпадает с расчетным листом. Переименуйте свой List12 на какое нибудь другое имя!»

End If

Next

If L = 0 Then

Worksheets.Add.Name = «List12»

Worksheets(1).Visible = True

Worksheets(«List12»).Visible = True

Worksheets(«List12»).Activate

End If

Вывод количества листов в активной книге

Sub Test()

 MsgBox (Str(Application.Workbooks.Item(ActiveWorkbook.Name).Sheets.Count))

End Sub

Вывод количества листов в активной книге в виде гиперссылок

Sub SheetNamesAsHyperLinks()

   Dim sheet As Worksheet

   Dim cell As Range

   With ActiveWorkbook

      ‘ Просмотр всех листов книги и создание гиперссылок на них _

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

      For Each sheet In ActiveWorkbook.Worksheets

         Set cell = Worksheets(1).Cells(sheet.Index, 1)

         .Worksheets(1).Hyperlinks.Add Anchor:=cell, Address:=»», _

          SubAddress:=»‘» & sheet.Name & «‘» & «!A1»

         cell.Formula = sheet.Name

      Next

   End With

End Sub

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

Sub Test()

With Application.Workbooks.Item(ActiveWorkbook.Name)

For x = 1 To .Sheets.Count

 MsgBox (Sheets.Item(x).Name)

Next x

End With

End Sub

Вывод имени и номеров листов текущей книги

Sub ShowInfo()

   Dim i As Integer

   ‘ Выводим имя файла рабочей книги

   Range(«A1») = ActiveWorkbook.Name

   ‘ Выводим имя текущего листа

   Range(«B1») = ActiveSheet.Name

   ‘ Выводим номера листов

   For i = 1 To ActiveWorkbook.Sheets.Count

      ActiveSheet.Cells(i, 3) = i

   Next i

End Sub

Сделать лист невидимым

Sub Test()

With Application.Workbooks.Item(«Test.xls»)

 .Sheets.Item(«Лист5»).Visible = False

End With

End Sub

Сколько страниц на всех листах?

Sub GetPrintPagesCount()

   Dim wshtSheet As Worksheet

   Dim intPagesCount As Integer

   ‘ Суммирование количества страниц, необходимых для печати всех _

    листов книги

   For Each wshtSheet In Worksheets

      intPagesCount = intPagesCount + (wshtSheet.HPageBreaks.Count + 1) * _

       (wshtSheet.VPageBreaks.Count + 1)

   Next

   MsgBox «Всего страниц: » & intPagesCount

End Sub

Ячейка и диапазон (столбцы и строки)

Копирование строк на другой лист

Sub CopyRows2()

Dim iCells As Range

For Each iCells In Range(«A2:A5»)

Range(iCells, iCells.Offset(, 7)).Copy

Workbooks.Add

ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:=»C:Temp» & iCells & «.xls»

Next iCells

End Sub

Копирование столбцов на другой лист

On Error Resume Next

s = Names(«sourcefilename»).Value

On Error GoTo 0

If s = «» Then

sfile = «progcall234_56g»

Call get_file

s = sfile

Else

s = Mid(s, 3, Len(s) — 3)

End If

If s = «» Then Exit Sub

Workbooks.Open (s)

Dim snm As String

snm = ActiveWorkbook.Name

ncol = WorksheetFunction.CountA(Range(«1:1»)) ‘ Range(«a1»).SpecialCells(xlLastCell).Column

nrow = WorksheetFunction.CountA(Range(«a:a»)) ‘Range(«a1»).SpecialCells(xlLastCell).Row

Range(Cells(1, 1), Cells(nrow, ncol)).Copy

Workbooks(s1).Activate

Range(«a1»).Activate

ActiveSheet.Paste

Application.DisplayAlerts = False

Workbooks(snm).Close

Подсчет количества ячеек, содержащих указанные значения_1

Function dhCount(rgn As Range, LowBound As Double, _

                UpperBound As Double) As ****

   Dim cell As Range

   Dim lngCount As ****

   ‘ Проходим по всем ячейкам диапазона rgn и подсчитываем значения, _

    попадающие в интервал от LowBound до UpperBound

   For Each cell In rgn

      If cell.Value >= LowBound And cell.Value <= UpperBound Then

         ‘ Значение попадает в заданный интервал

         lngCount = lngCount + 1

      End If

   Next

   dhCount = lngCount

End Function

Подсчет количества ячеек в диапазоне, содержащих указанные значения_2

Function dhCountSomeCells(rgRange As Range, dblMin As Double, _

 dblMax As Double) As ****

   ‘ Расчет количества ячеек со значениями от dblMin до dblMax _

    с использованием стандартной функции CountIf

   With Application.WorksheetFunction

      dhCountSomeCells = .CountIf(rgRange, «>=» & dblMin) — _

       .CountIf(rgRange, «>» & dblMax)

   End With

End Function

Подсчет количества видимых ячеек в диапазоне

Function dhCountVisibleCells(rgRange As Range)

   Dim lngCount As ****

   Dim cell As Range

   ‘ Проходим по всему диапазону и подсчитываем непустые _

    видимые ячейки

   For Each cell In rgRange

      ‘ Проверка, есть ли данные в ячейке

      If Not IsEmpty(cell) Then

         ‘ Проверка, видима ли ячейка

         If Not cell.EntireRow.Hidden And Not _

          cell.EntireColumn.Hidden Then

            ‘ Еще одна видимая ячейка

            lngCount = lngCount + 1

         End If

      End If

   Next cell

   dhCountVisibleCells = lngCount

End Function

Определение количества ячеек в диапазоне и суммы их значений

Sub CalculateSum()

   Dim i As Integer

   Dim intSum As Integer

   ‘ Расчет суммы ячеек столбца «A» (с первой по пятую)

   For i = 1 To 5

      intSum = intSum + Cells(i, 1)

   Next

   MsgBox «Сумма ячеек: » & intSum

End Sub

Подсчет количества ячеек

Sub CountOfCells()

   MsgBox (Range(«A1:A20, D1:D20»).Count)

End Sub

Автоматический пересчет данных таблицы при изменении ее значений

Sub Worksheet_Change(ByVal Target As Range)

   Dim rgData As Range

   Dim cell As Range

   Dim dblMax As Double, dblMin As Double, dblAverage As Double

   ‘ Получение контролируемого диапазона ячеек

   Set rgData = Range(«B2:B11»)

   ‘ Проверка, не входит ли измененная ячейка в контролируемый _

    диапазон

   If Not (Application.Intersect(Target, rgData) Is Nothing) Then

      If Application.WorksheetFunction.CountA(rgData) > 0 Then

         ‘ Изменена ячейка из контролируемого диапазона

         ‘ Заново рассчитываем минимальное, максимальное и среднее _

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

         dblMin = Application.WorksheetFunction.Min(rgData)

         dblMax = Application.WorksheetFunction.Max(rgData)

         dblAverage = Application.WorksheetFunction.Average(rgData)

         ‘ Проверяем каждую ячейку из контролируемого диапазона _

          и изменяем цвет шрифта ячеек с минимальным и максимальным _

          значениями, а также помечаем желтым цветом ячейки _

          со значениями больше среднего

         For Each cell In rgData

            If cell.Value = dblMax Then

               ‘ Ячейку с максимальным значением выделим красным цветом

               cell.Font.Bold = True

               cell.Font.Color = RGB(255, 0, 0)

            ElseIf cell.Value = dblMin Then

               ‘ Ячейку с минимальным значением выделим синим цветом

               cell.Font.Bold = False

               cell.Font.Color = RGB(0, 0, 255)

            Else

               cell.Font.Bold = False

               cell.Font.Color = RGB(0, 0, 0)

            End If

            If cell.Value > dblAverage Then

               ‘ Значение в ячейке больше среднего — выделим ее _

                желтым цветом

               cell.Interior.Color = RGB(255, 255, 0)

            Else

               cell.Interior.ColorIndex = xlNone

            End If

         Next

      Else

         rgData.Interior.ColorIndex = xlNone

      End If

   End If

End Sub

Ввод данных в ячейки

Sub SetCellData()

   ‘ Заполнение значениями ячеек А3 и В4

   Range(«A3») = «Данные для ячейки A3»

   Range(«B4») = «Данные для ячейки B4»

End Sub

Ввод данных с использованием формул

Sub SetCellFormula()

   ‘ Запись в ячейку А6 формулы «=A5+B5»

   Range(«A6») = «=A5+B5»

End Sub

Последовательный ввод данных

Sub StreamInput()

   Dim strDate As String

   Dim strSum As String

   Dim lngRow As ****

   ‘ Ввод данных в цикле (повторяется до тех пор, пока пользователь _

    не введет пустую строку или не нажмет «Отмена» в окне ввода)

   Do

      lngRow = Range(«A65536»).End(xlUp).Row + 1

      ‘ Ввод даты

      strDate = InputBox(«Вводим дату»)

      If strDate = «» Then Exit Sub

      ‘ Ввод выручки

      strSum = InputBox(«Вводим выручку»)

      If strSum = «» Then Exit Sub

      ‘ Запись данных в ячейки

      Cells(lngRow, 1) = strDate

      Cells(lngRow, 2) = strSum

   Loop

End Sub

Ввод текстоввых данных в ячейки

Sub insеrtCustomText()

   ‘ Заполнение текущей ячейки

   ActiveCell = «Генеральный директор»

   Selection.Font.Bold = True

   ‘ Фамилия на три столбца правее должности

   Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

   ActiveCell.FormulaR1C1 = «А. Б. Рублев»

   Selection.Font.Bold = True

   ‘ Ячейка с «Главный бухгалтер» на три столбца левее _

    и на три строки ниже ячейки с фамилией директора

   Cells(ActiveCell.Row + 3, ActiveCell.Column — 3).Select

   ActiveCell = «Главный бухгалтер»

   Selection.Font.Bold = True

   ‘ Фамилия на три столбца правее должности

   Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

   ActiveCell = «Т. С. Копейкин»

   Selection.Font.Bold = True

End Sub

Вывод в ячейки названия книги, листа и количества листов

Sub Test()

 Dim book As String

 Dim sheet As String

 Dim addr As String

 addr = «C»

 book = Application.ActiveWorkbook.Name

 sheet = Application.ActiveSheet.Name

 Workbooks(book).Activate

 Worksheets(sheet).Activate

 Range(«A1») = book

 Range(«B1») = sheet

 Dim xList As Integer

 xList = Application.Sheets.Count

 For x = 1 To xList

   Dim s As String

   s = addr + LTrim(Str(x))

   Range(s) = x

 Next x

End Sub

Удаление пустых строк_1

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.Delete Shift:=xlUp

Удаление пустых строк_2

Sub DeleteEmptyStrings()

   Dim intLastRow As Integer  ‘ Номер последней используемой строки

   Dim intRow As Integer      ‘ Номер проверяемой строки

   ‘ Получение номера последней используемой строки

   intLastRow = Worksheets(ActiveSheet.Index).UsedRange.Row + _

    Worksheets(ActiveSheet.Index).UsedRange.Rows.Count — 1

   ‘ Счетчик устанавливается на используемую первую строку

   intRow = Worksheets(ActiveSheet.Index).UsedRange.Row

   ‘ Удаление пустых строк

   Do While intRow <= intLastRow

      If ActiveSheet.Rows(intRow).Text = «» Then

         ‘ Удаление строки

         ActiveSheet.Rows(intRow).Delete

         ‘ Данные сдвинулись вверх, поэтому номер последней _

          строки уменьшился, а текущей — не изменился

         intLastRow = intLastRow — 1

      Else

         ‘ Текущая строка заполнена — переходим к следующей

         intRow = intRow + 1

      End If

   Loop

End Sub

Удаление пустых строк_3

Sub DeleteEmptyStrings1()

   Dim intRow As Integer

   Dim intLastRow As Integer

   ‘ Получение номера последней используемой строки

   intLastRow = ActiveSheet.UsedRange.Row + _

    ActiveSheet.UsedRange.Rows.Count — 1

   ‘ Удаление пустых строк

   For intRow = intLastRow To 1 Step -1

      If ActiveSheet.Rows(intRow).Text = «» Then

         ActiveSheet.Rows(intRow).Delete

      End If

   Next intRow

End Sub

Удаление строки по условию

Sub Макрос1()

Dim iRange As Range

Dim TextToFindArray As Variant

Dim i As ****

TextToFindArray = Array(«Toyota», «ВАЗ»)

With Application

.ScreenUpdating = False

.Calculation = xlCalculationManual

For i = 0 To 1

With ActiveSheet.Cells

Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)

If Not iRange Is Nothing Then

Do

iRange.EntireRow.Delete

Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)

Loop While Not iRange Is Nothing

End If

End With

Next i

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

MsgBox «Строки с текстом » & TextToFindArray(0) & » и » & TextToFindArray(1) & » удалены!», 64, «Конец»

End Sub

Удаление скрытых строк

Sub KillHiddenRows()

For Each x In ActiveSheet.Rows

If x.Hidden Then x.Delete

Next

End Sub

Удаление используемых скрытых строк или строк с нулевой высотой

Sub KillUsedHiddenThinRows()

Dim x

For Each x In ActiveSheet.UsedRange.Rows

If x.Hidden Or x.Height = 0 Then x.EntireRow.Delete

Next

End Sub

Удаление дубликатов по маске

Function Two2One(Text As String) As String

Dim Polki, i As Byte, tmp As String

Application.Volatile

Polki = Split(Text, «@»)

For i = 1 To UBound(Polki)

If InStr(1, Polki(i), «:») > 0 Then

If Polki(i) <> Polki(i — 1) Then tmp = tmp & «@» & Polki(i)

Else: tmp = tmp & «@» & Polki(i)

End If

Next

Two2One = Polki(0) & tmp

End Function

Выделение диапазона над текущей ячейкой

Sub SelectCellRange()

   Dim strSelTop As String, strSelBottom As String

   ‘ Получение адресов нижней и верхней ячеек диапазона для выделения

   strSelBottom = ActiveCell.Address

   strSelTop = Cells(1, ActiveCell.Column).Address

   ‘ Выделяем все ячейки выше текущей (вместе с текущей ячейкой)

   Range(strSelTop & «:» & strSelBottom).Select

End Sub

Выделение диапазона над текущей ячейкой_2

Sub SelectColumnData()

‘ что делать при ошибке

On Error GoTo errors

‘ нижний адрес

Dim a1 As String

‘ верхний адрес

Dim a2 As String

‘ диапазое

Dim ran As Range

‘ если не верхнея ячейка

If (ActiveCell.Row <> 1) Then

‘ пойти вверх

ActiveCell.Offset(-1, 0).Select

‘ взять адрес ячейки

a1 = ActiveCell.Address

‘ будем подниматься

For x = 1 To (ActiveCell.Row — 1)

‘ на одну вверх

ActiveCell.Offset(-1, 0).Select

‘ если не число выход

If IsNumeric(ActiveCell.Value) <> True Then

‘ на одну вниз

ActiveCell.Offset(1, 0).Select

‘ выход

GoTo nexts

End If

‘ если пустая

If IsEmpty(ActiveCell.Value) = True Then

‘ на одну вниз

ActiveCell.Offset(1, 0).Select

‘ выход

GoTo nexts

End If

Next x

nexts:

‘ получаем адрес вырехней

a2 = ActiveCell.Address

‘ строим диапазон

Set ran = Range(a1 + «:» + a2)

‘ выбеляем

ran.Select

End If

‘ выходим из процедуры

Exit Sub

‘ ошибка зовем на помощь

errors:

MsgBox «Ошибка сообщите разработчику»

End Sub

Выделить ячейку и поместить туда число

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

 Worksheets(«Лист2»).Activate

 Range(«A2») = 2

 Range(«A3») = 3

 End With

End Sub

Выделение отрицательных значений

Sub NegSelect()

   Dim cell As Range

   ‘ Просмотр всех ячеек выделенного диапазона и пометка тех, _

    которые содержат отрицательные значения

   For Each cell In Selection

      If cell.Value < 0 Then

         cell.Interior.Color = RGB(255, 0, 0)

      Else

         cell.Interior.ColorIndex = xlNone

      End If

   Next cell

End Sub

Выделение диапазона и использование абсолютных адресов

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

  Worksheets(«Лист2»).Activate

  Dim HelloRange As Range

  Set HelloRange = Range(«D3:D10») ‘можно через запятую выделять несколько интервалов или яче

  HelloRange.Range(«A1») = 3

 End With

End Sub

Выделение ячеек через интервал_1

Sub IntervalCellSelect()

   Dim intFirstRow As Integer  ‘ Первая строка для выделения

   Dim intLastRow As Integer   ‘ Последняя строка для выделения

   Dim rgCells As Range        ‘ Объединение выделяемых ячеек

   Dim intRow As Integer

   intFirstRow = 3

   intLastRow = 300

   ‘ Формирование объединения ячеек в столбце «B» от строки _

    intFirstRow до строки intLastRow с шагом 3

   For intRow = intFirstRow To intLastRow Step 3

      If rgCells Is Nothing Then

         ‘ Первая ячейка в объединении

         Set rgCells = Cells(intRow, 1)

      Else

         ‘ Добавление очередной ячейки в объединение

         Set rgCells = Union(rgCells, Cells(intRow, 1))

      End If

   Next

   ‘ Выделение всех ячеек в объединении

   rgCells.Select

End Sub

Выделение ячеек через интервал_2

Sub IntervalCellSelect()

   Dim intFirstRow As Integer  ‘ Первая строка для выделения

   Dim intLastRow As Integer   ‘ Последняя строка для выделения

   Dim rgCells As Range        ‘ Объединение выделяемых ячеек

   Dim cell As Range           ‘ Текущая ячейка

   Dim intRow As Integer

   intFirstRow = 3

   intLastRow = 300

   ‘ Формирование объединения ячеек в столбце «B» от строки _

    intFirstRow до строки intLastRow с шагом 3

   For intRow = intFirstRow To intLastRow Step 3

      Set cell = Cells(intRow, 1)

      Set rgCells = Union(cell, _

      IIf(intRow = intFirstRow, cell, rgCells))

   Next

   ‘ Выделение всех ячеек в объединении

   rgCells.Select

End Sub

Выделение нескольких диапазонов

Sub SelectRange()

   Range(«D3:D10, A3:A10 , F3»).Select

End Sub

Движение по ячейкам

переменная.Offset(RowOffset, ColumnOffset)

В качестве переменных может выступать как ячейка так и диапазон (Range) удобно пользоваться этой функцией для смещения относительно текущей ячейки.

Например, смещение ввниз на одну ячейку и выделение ее:

ActiveCell.Offset(1, 0).Select

Если нужно двигаться вверх, то нужно использовать отрицательное число:

ActiveCell.Offset(-1, 0).Select

Функция ниже использует эту возможность для того, чтобы пробежаться вниз до первой пустой ячейки.

Sub beg()

            Dim a As Boolean

            Dim d As Double

            Dim c As Range

            a = True

            Set c = Range(ActiveCell.address)

            c.Select

            d = c.Value

            c.Value = d

            While (a = True)

                        ActiveCell.Offset(1, 0).Select

                        If (IsEmpty(ActiveCell.Value) = False) Then

                                   Set c = Range(ActiveCell.address)

                                   c.Select

                                   d = c.Value

                                   c.Value = d

                        Else

                                   a = False

                        End If

            Wend

End Sub

Поиск ближайшей пустой ячейки столбца

Sub FindEmptyCell()

   ‘ Поиск ближайшей пустой ячейки в текущем столбце

   Do While Not IsEmpty(ActiveCell.Value)

      ActiveCell.Offset(1, 0).Select

   Loop

End Sub

Поиск максимального значения

Sub FindMaxValue()

   On Error Goto NoCell

   If Selection.Count > 1 Then

      ‘ Поиск максимального значения в выделенных ячейках

      Selection.Find(Application.Max(Selection)).Select

   Else

      ‘ Поиск максимального значения во всех ячейках листа

      ActiveSheet.Cells.Find(Application.Max(ActiveSheet.Cells)).Select

   End If

   Exit Sub

NoCell:

   MsgBox «Максимальное значение не найдено»

End Sub

Поиск и замена по шаблону

Sub ReplaceCellsData()

   Dim cell As Range

   ‘ Просмотр всех ячеек диапазона G1:K20 и замена искомого текста

   For Each cell In [G1:K20]

      If cell.Value Like «*Доход*» Then

         cell.Value = «Выручка»

         cell.Interior.Color = RGB(255, 255, 0)

      Else

         cell.Interior.Color = RGB(255, 255, 255)

      End If

   Next

End Sub

Поиск значения с отображением результата в отдельном окне

Sub Search()

   Dim rgResult As Range

   ‘ Поиск заданного значения в диапазоне B1:B20 и вывод результата

   Set rgResult = Range(«B1:B20»).Find(9999, , xlValues)

   If rgResult Is Nothing Then

      MsgBox «Поиск не дал результатов»

   Else

      MsgBox rgResult.Address

   End If

End Sub

Поиск с выделением найденных данных_1

Sub FindAndSelect()

   Dim strStartAddr As String ‘ Хранит координаты первого найденного _

                               значения

   Dim rgResult As Range

   ‘ Поиск первого входжения искомого слова

   Set rgResult = Range(«B1:B10»).Find(«Прибыль», , xlValues)

   If Not rgResult Is Nothing Then

      ‘ Сохраним адрес найденной ячейки (чтобы контролировать _

       зацикливание поиска)

      strStartAddr = rgResult.Address

   End If

   Do While Not rgResult Is Nothing

      ‘ Обработка результата поиска

      rgResult.Interior.Color = RGB(255, 255, 0)

      ‘ Новый поиск

      Set rgResult = Range(«B1:B10»).FindNext(rgResult)

      If rgResult.Address = strStartAddr Then

         ‘ Поиск завершен

         Exit Do

      End If

   Loop

End Sub

Поиск с выделением найденных данных_2

Sub CustomSearch()

   Dim strFindData As String

   Dim rgFound As Range

   Dim i As Integer

   ‘ Ввод строки для поиска

   strFindData = InputBox(«Введите данные для поиска»)

   ‘ Просмотр всех рабочих листов книги

   For i = 1 To Worksheets.Count

      With Worksheets(i).Cells

         ‘ Поиск на i-м листе

         Set rgFound = .Find(strFindData, LookIn:=xlValues)

         If Not rgFound Is Nothing Then

            ‘ Ячейка с заданным значением найдена — выделим ее

            Sheets(i).Select

            rgFound.Select

            Exit Sub

         End If

      End With

   Next

   ‘ Поиск завершен. Ячейка не найдена

   MsgBox («Поиск не дал результатов»)

End Sub

Поиск по условию в диапазоне

Option Explicit

Sub Поиск()

Dim iFoundRng As Range

Dim AutoNum As String

Dim firstAddress As String

Dim LastFoundRng As String

    AutoNum = Range(«E5»)

    If AutoNum = «» Then

        MsgBox «Вы не указали номер авто в ячейке Е5!», 48, «Ошибка»

        Exit Sub

    End If

    On Error Resume Next

    LastFoundRng = ActiveWorkbook.Names(«LastFoundRngName»).RefersToRange.Address

    If LastFoundRng = «» Then LastFoundRng = «$C$1»

    With Columns(«C»)

        Set iFoundRng = .Find(What:=AutoNum, After:=Range(LastFoundRng), LookIn:=xlFormulas, LookAt:=xlWhole)

        If iFoundRng Is Nothing Then

            MsgBox «Авто с номером » & AutoNum & » не найдено в столбце С!», «48», «Ошибка»

            Exit Sub

        End If

        ActiveWorkbook.Names.Add Name:=»LastFoundRngName», RefersTo:=»=» & ActiveSheet.Name & «!» & iFoundRng.Address, Visible:=False

    End With

    [E7] = iFoundRng.Offset(0, 1)

    [F7] = iFoundRng.Offset(0, 2)

End Sub

Поиск последней непустой ячейки диапазона

Function dhLastUsedCell(rgRange As Range) As ****

   Dim lngCell As ****

   ‘ Пойдем по диапазону с конца (тогда первая попавшаяся _

    заполненная ячейка и будет искомой)

   For lngCell = rgRange.Count To 1 Step -1

      If Not IsEmpty(rgRange(lngCell)) Then

         ‘ Нашли непустую ячейку

         dhLastUsedCell = lngCell

         Exit Function

      End If

   Next lngCell

   ‘ Непустую ячейку не нашли

   dhLastUsedCell = 0

End Function

Поиск последней непустой ячейки столбца

Function dhLastColUsedCell(rgColumn As Range) As Variant

   ‘ Вывод значения последней непустой ячейки столбца

   dhLastColUsedCell = rgColumn.Parent.Cells(Rows.Count, _

    rgColumn.Column).End(xlUp).Value

End Function

Поиск последней непустой ячейки строки

Function dhLastRowUsedCell(rgRow As Range) As Variant

   ‘ Вывод значения последней непустой ячейки строки

   dhLastRowUsedCell = rgRow.Parent.Cells(rgRow.Row, 256). _

    End(xlToLeft).Address

End Function

Поиск ячейки синего цвета в диапазоне

Sub Макрос1()

Dim myRange As Range ‘диапазон для поиска

Dim FoundRng As Range ‘найденная ячейка

Dim iRow As ****

Dim iColumn As ****

Set myRange = Range(«B1:B100»)

Application.FindFormat.Interior.ColorIndex = 5 ‘будем искать синий цвет

Set FoundRng = myRange.Find(What:=»», SearchFormat:=True)

If Not FoundRng Is Nothing Then

iRow = FoundRng.Row

iColumn = FoundRng.Column

MsgBox «Ячейка найдена по адресу: » & Chr(13) & «Ряд: » & iRow & Chr(13) & «Столбец: » & iColumn, vbInformation, «»

Else

MsgBox «Ячейка не найдена!», vbExclamation, «»

End If

End Sub

Поиск наличия значения в столбце

Sub Макрос1()

Dim iCell As Range

Set iCell = Columns(1).Find(What:=»*», LookIn:=xlFormulas, SearchDirection:=xlPrevious)

If Not iCell Is Nothing Then

MsgBox «Номер последней заполненной строки в столбце A: » & iCell.Row, , «»

Else

MsgBox «Столбец «»A»» не содержит данных», vbExclamation, «»

End If

End Sub

Поиск совпадений в диапазоне

Option Explicit

Sub compare_areas()

Dim r As Range, ar As Range, nm As String, col As Range

Set r = Selection

If r.Count < 2 Then Exit Sub

‘Dim r_prog As Integer

‘r_prog = prog

‘prog = 1

Application.ScreenUpdating = False

nm = ActiveSheet.Name

Sheets.Add

For Each ar In r.Areas

   For Each col In ar.Columns

      col.Copy

      ActiveSheet.Paste

      ActiveCell.SpecialCells(xlLastCell).Offset(1, 0).Select

   Next

Next

Range(Cells(1, 1), Cells(r.Cells.Count, 2)).Select

Selection.Sort Key1:=Range(«A1»), Order1:=xlAscending, Header:=xlGuess, _

    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

    DataOption1:=xlSortTextAsNumbers

Rows(«1:1»).Select

Selection.insеrt Shift:=xlDown

Cells(2, 2).FormulaR1C1 = «=IF((RC[-1]=R[-1]C[-1])+(RC[-1]=R[1]C[-1]),1,0)»

Range(«b2»).Select

Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)), Type:=xlFillDefault

Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)).Copy

Cells(2, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

Application.CutCopyMode = False

For Each ar In r.Cells

    If ar.Value <> Empty Then

        If WorksheetFunction.VLookup(ar.Value, Range(Cells(2, 1), Cells(r.Count + 1, 2)), 2, 0) Then

            ar.Interior.ColorIndex = 3

        End If

    End If

Next

Application.DisplayAlerts = False

ActiveSheet.Delete

Sheets(nm).Select

ActiveCell.Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

‘prog = r_prog

End Sub

Sub uncolor()

    Selection.Interior.ColorIndex = xlNone

End Sub

Поиск ячейки в диапазоне_1

Dim r As Range

Dim foundCell As Range

Set r = ActiveSheet.Range(«A1:A6»)

Set foundCell = r.Find(«Ichiro», LookIn:=xlValues)

If Not foundCell Is Nothing Then

    foundCell.Select

Else

    MsgBox «String not found.»

End If

Поиск  ячейки в диапазоне_2

Sub findtekst()

Dim c As Range

Set c = Range(«c3:c98»).Find(«*ГКИ*», , , xlWhole)

If Not c Is Nothing Then c.Select

MsgBox (c)

End Sub

Также для финда по xlWhole вариации:

«*a» — заканчивается на a

«?a*» — 2-я буква a

«??a*» — 3-я буква а

«a?» — начинается на a и содержит ещё 1 любую букву

«a?*» — 2+ буквы минимум и начинается на a (например a1, a10, a12, a55, a55dd56 всё посчитается)

«*слово*» — находит слова содержащие «слово» в любой части строки (включая начало и конец)

«слово*» — находит ячейки начинающиеся со «слово» или просто ячейку «слово» без дополнительных букв

Поиск приближенного значения в диапазоне

Sub wwe()

Dim foundCell As Range

    ActiveWorkbook.Names.Add Name:=»ev», RefersToR1C1:= _

        «=INDEX(Лист1!R11C2:R34C2,MATCH(MIN(ABS(Лист1!R36C2:R234C2-Лист1!R28C1)),ABS(Лист1!R36C2:R234C2-Лист1!R28C1),0))»

Set foundCell = [ev]

Names(«ev»).Delete

If Not foundCell Is Nothing Then

foundCell.Select

Else

MsgBox «String not found.»

End If

End Sub

Поиск начала и окончания диапазона, содержащего данные

Sub FindSheetData()

   ‘ Выводим диапазон используемых ячеек листа

   MsgBox ActiveSheet.UsedRange.Address

End Sub

Поиск начала данных

Sub FindStartOfData()

   With ActiveSheet

      ‘ Заносим текст в ячейку, являющуюся левой верхней _

       ячейкой используемого диапазона

      .Cells(.UsedRange.Row, .UsedRange.Column).Value = _

       «Начало данных»

   End With

End Sub

Автоматическая замена значений

Sub ReplaceValues()

   Dim cell As Range

   ‘ Проверка каждой ячейки диапазона на возможность замены _

    значения в ней (отрицательные значения заменяются на -1, _

    положительные — на 1)

   For Each cell In Range(«C1:C3»).Cells

      If cell.Value < 0 Then

         cell.Value = -1

      ElseIf cell.Value > 0 Then

         cell.Value = 1

      End If

   Next

End Sub

Быстрое заполнение диапазона (массив)

Sub FillCells()

   Dim intStartVal As Integer   ‘ Начальное значение

   Dim intStep As Integer       ‘ Шаг при изменении значения

   Dim intEndVal As Integer     ‘ Конечное значение

   Dim intVal As Integer        ‘ Текущее значение

   Dim intCellOffset As Integer ‘ Смещение от начальной ячейки

   ‘ Установка параметров заполнения

   intStartVal = 1

   intStep = 1

   intEndVal = 100

   ‘ Заполнение ячеек текущего столбца значениями от 1 до 100

   For intVal = intStartVal To intEndVal Step intStep

      ActiveCell.Offset(intCellOffset, 0).Value = intVal

      intCellOffset = intCellOffset + 1

   Next intVal

End Sub

Заполнение через интервал(массив)

Sub FillCells()

   Dim intStartVal As Integer   ‘ Начальное значение

   Dim intStep As Integer       ‘ Шаг при изменении значения

   Dim intEndVal As Integer     ‘ Конечное значение

   Dim intVal As Integer        ‘ Текущее значение

   Dim intCellOffset As Integer ‘ Смещение от начальной ячейки

   Dim intCellStep As Integer   ‘ Шаг при перемещении между _

                                 заполняемыми ячейками

   ‘ Установка параметров заполнения

   intStartVal = 3

   intStep = 3

   intEndVal = 30

   intCellStep = 3

   ‘ Заполнение ячеек текущего столбца значениями от 3 до 30

   For intVal = intStartVal To intEndVal Step intStep

      ActiveCell.Offset(intCellOffset, 0).Value = intVal

      intCellOffset = intCellOffset + intCellStep

   Next intVal

End Sub

Заполнение указанного диапазона(массив)

Sub FillCellRect()

   Dim lngRows As ****, intCols As Integer ‘ Количество ячеек по _

                                            горизонтали и вертикали

   Dim lngRow As ****, intCol As Integer   ‘ Координаты текущей ячейки

   Dim lngStep As ****, lngVal As ****

   ‘ Установка начального значения и шага заполнения

   lngVal = 1

   lngStep = 1

   ‘ Ввод количества ячеек по горизонтали и вертикали, которое _

    необходимо заполнить

   lngRows = Val(InputBox(«Количество ячеек в высоту»))

   intCols = Val(InputBox(«Количество ячеек в ширину»))

   ‘ Отключение обновления экрана

   Application.ScreenUpdating = False

   ‘ Заполнение ячеек значениями

   For lngRow = 1 To lngRows

      For intCol = 1 To intCols

         ActiveCell.Offset(lngRow, intCol).Value = lngVal

         lngVal = lngVal + lngStep

      Next intCol

   Next lngRow

   ‘ Включение обновления экрана

   Application.ScreenUpdating = True

End Sub

Заполнение диапазона(массив)

Sub FillCellRect1()

   Dim lngRows As ****, intCols As Integer

   Dim lngRow As ****, intCol As Integer

   Dim lngStep As ****, lngVal As ****

   Dim alngValues() As ****

   Dim rgRange As Range

   ‘ Установка начального значения и шага заполнения

   lngVal = 1

   lngStep = 1

   ‘ Ввод количества ячеек по горизонтали и вертикали, которое _

    необходимо заполнить

   lngRows = Val(InputBox(«Количество ячеек в высоту»))

   intCols = Val(InputBox(«Количество ячеек в ширину»))

   ReDim alngValues(1 To lngRows, 1 To intCols)

   Set rgRange = ActiveCell.Range(Cells(1, 1), _

    Cells(lngRows, intCols))

   ‘ Заполнение массива alngValues значениями

   For lngRow = 1 To lngRows

      For intCol = 1 To intCols

         alngValues(lngRow, intCol) = lngVal

         lngVal = lngVal + lngStep

      Next intCol

   Next lngRow

   ‘ Перенос значений из массива в таблицу

   rgRange.Value = alngValues

End Sub

Расчет суммы первых значений диапазона

Листинг 2.65. Функция dhNSum

Function dhNSum(ByVal intCount As Integer, _

 rgValues As Range) As Double

   Dim i As Integer

   Dim dblSum As Double

   If intCount > rgValues.Count Then

      ‘ Задано количество элементов большее, чем есть _

       в переданном диапазоне

      intCount = rgValues.Count

   End If

   ‘ Расчет суммы первых intCount элементов

   For i = 1 To intCount

      dblSum = dblSum + rgValues(i)

   Next i

   ‘ Возврат результата

   dhNSum = dblSum

End Function

Размещение в ячейке электронных часов

Sub updаtеTime()

   Dim varNextCall As Variant

   ‘ Записываем в ячейку текущее время

   Cells(1, 1).Value = Now

   ‘ Записываем в varNextCall время, когда вызвать этот макрос _

    в следующий раз (через 1 секунду)

   varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1)

   ‘ Уведомляем Excel в необходимости вызова макроса

   Application.OnTime varNextCall, «updаtеTime»

End Sub

 «Будильник»

Sub Clock()

   ‘ Уведомляем Excel, что процедуру Alarm нужно вызвать в 20:55

   Application.OnTime TimeValue(«20:55:00»), «Alarm»

End Sub

Sub Alarm()

   MsgBox «Пора ужинать!!!»

End Sub

Оформление верхней и нижней границ диапазона

Sub RangeBorder()

   Dim rgRange As Range

   Set rgRange = Range(«B2:D5»)

   ‘ Оформление верхней границы диапазона

   With rgRange.Borders(xlEdgeTop)

      .Weight = xlThick

      .LineStyle = xlContinuous

      .Color = RGB(0, 0, 255)

   End With

   ‘ Оформление нижней границы диапазона

   With rgRange.Borders(xlEdgeBottom)

      .Weight = xlMedium

      .LineStyle = xlDash

      .Color = RGB(255, 0, 255)

   End With

End Sub

Адрес активной ячейки

Sub Worksheet_Selectiоnchange(ByVal Target As Range)

   ‘ Вывод адреса ячейки в различных форматах

   MsgBox Target.Address() & vbCr & _

    Target.Address(RowAbsolute:=False) & vbCr & _

    Target.Address(ReferenceStyle:=xlR1C1) & vbCr & _

    Target.Address(ReferenceStyle:=xlR1C1, _

     RowAbsolute:=False, ColumnAbsolute:=False, _

     RelativeTo:=Worksheets(1).Cells(2, 2))

End Sub

Координаты активной ячейки

ActiveCell.Row и ActiveCell.Column — покажут координаты активной ячейки.

Формула активной ячейки

s = Range(«A3»).Formula

Получение из ячейки формулы

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

  Worksheets(«Лист2»).Activate

  Range(«A2») = 2

  Range(«A3») = «=A2+2»

  MsgBox Range(«A3″).Formula + »  — » + Str(Range(«A3»).Value)

 End With

End Sub

Тип данных ячейки

Function dhCellType(rgRange As Range) As String

   ‘ Переходим к левой верхней ячейке, если rgRange — диапазон, _

    а не одна ячейка

   Set rgRange = rgRange.Range(«A1»)

   ‘ Определение типа значения в ячейке

   Select Case True

      Case IsEmpty(rgRange)

         ‘ Ячейка пуста

         dhCellType = «Пусто»

      Case Application.IsText(rgRange)

         ‘ В ячейке текст

         dhCellType = «Текст»

      Case Application.IsLogical(rgRange)

         ‘ В ячейке логическое значение (True или False)

         dhCellType = «Булево выражение»

      Case Application.IsErr(rgRange)

         ‘ При вычислении значения в ячейке произошла ошибка

         dhCellType = «Ошибка»

      Case IsDate(rgRange)

         ‘ В ячейке дата

         dhCellType = «Дата»

      Case InStr(1, rgRange.Text, «:») <> 0

         ‘ В ячейке время

         dhCellType = «Время»

      Case IsNumeric(rgRange)

         ‘ В ячейке числовое значение

         dhCellType = «Число»

   End Select

End Function

Вывод адреса конца диапазона

Sub TestRange()

            Dim r As Range

            Set r = Range(«rrrrr»)

            MsgBox (r.Columns.End(xlUp).Address)

            MsgBox (r.Columns.End(xlDown).Address)

End Sub

Получение информации о выделенном диапазоне

Sub TypeOfSelection()

   Dim rgSelUnion As Range         ‘ Объединение выделенных областей

   Dim strTitle As String          ‘ Заголовок сообщения

   Dim strMessage As String        ‘ Текст сообщения

   Dim strSelType As String        ‘ Тип выделения (простой или _

                                    множественный)

   Dim intBlockCount As Integer    ‘ Количество блоков в выделении

   Dim intCellCount As ****        ‘ Общее количество выделенных ячеек

   Dim intColCount As Integer      ‘ Количество выделенных столбцов

   Dim intRowCount As ****         ‘ Количество выделенных строк

   Dim intAreasCount As Integer    ‘ Количество выделенных областей

   Dim strCurSelType  As String

   Dim rgArea As Range

   ‘ Подсчет количества выделенных областей и определение типа выделения: _

    простое (одна область) или сложное(несколько областей)

   intAreasCount = Selection.Areas.Count

   If intAreasCount = 1 Then

      strTitle = «Простое выделение»

   Else

      strTitle = «Множественное выделение»

   End If

   ‘ Определение типа выделения первой области

   strSelType = dhGetAreaType(Selection.Areas(1))

   ‘ Создание объединения во избежание повторного учета _

    пересекающихся участков выделенных диапазонов

   Set rgSelUnion = Selection.Areas(1)

   For Each rgArea In Selection.Areas

      strCurSelType = dhGetAreaType(rgArea)

      ‘ Изменение надписи о типе всего выделения, если _

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

      If strCurSelType <> strSelType Then

         strSelType = «Множественный»

      End If

      ‘ Определение количества блоков перед их добавлением в объединение

      If strCurSelType = «Block» Then

         intBlockCount = intBlockCount + 1

      End If

      ‘ Добавление в объединение

      Set rgSelUnion = Union(rgSelUnion, rgArea)

   Next rgArea

   ‘ Просматриваются элементы созданного объединения

   For Each rgArea In rgSelUnion.Areas

      Select Case dhGetAreaType(rgArea)

         Case «Строка»

            intRowCount = intRowCount + rgArea.Rows.Count

         Case «Столбец»

            intColCount = intColCount + rgArea.Columns.Count

         Case «Лист»

            intColCount = intColCount + rgArea.Columns.Count

            intRowCount = intRowCount + rgArea.Rows.Count

      End Select

   Next rgArea

   ‘ Определение количества неперекрывающихся ячеек

   intCellCount = rgSelUnion.Count

   ‘ Формирование и вывод итогового сообщения

   strMessage = «Тип выделения:» & vbTab & strSelType & vbCrLf & _

    «Количество областей:      » & vbTab & intAreasCount & vbCrLf & _

    «Полных столбцов:          » & vbTab & intColCount & vbCrLf & _

    «Полных строк:             » & vbTab & intRowCount & vbCrLf & _

    «Блоков ячеек:             » & vbTab & intBlockCount & vbCrLf & _

    «Всего ячеек:              » & vbTab & Format(intCellCount, «#,###»)

   MsgBox strMessage, vbInformation, strTitle

End Sub

Function dhGetAreaType(rgRangeArea As Range) As String

   ‘ Определение типа диапазона

   If rgRangeArea.Count = Cells.Count Then

      ‘ Все ячейки рабочего листа

      dhGetAreaType = «Лист»

   ElseIf rgRangeArea.Cells.Count = 1 Then

      ‘ Одна ячейка

      dhGetAreaType = «Ячейка»

   ElseIf rgRangeArea.Rows.Count = Cells.Rows.Count Then

      ‘ Весь столбец

      dhGetAreaType = «Столбец»

   ElseIf rgRangeArea.Columns.Count = Cells.Columns.Count Then

      ‘ Вся строка

      dhGetAreaType = «Строка»

   Else

      ‘ Блок ячеек

      dhGetAreaType = «Блок»

   End If

End Function

Взять слово с 13 символа в ячейке

‘берём значение ячейка А4 из Отчёта

iMonth = «за период с Июль 2 008 по Июль 2 008 »

‘берём слово начиная с 13-го символа

iMonth = Evaluate(«MID(TRIM(» & «»»» & iMonth & «»»» & «),13,(SEARCH(«» «»,TRIM(» & «»»» & iMonth & «»»» & «),13)-13))»)

‘вставляем это слово в книгу Ведомость

AddressSht.Range(«A1») = iMonth

Создание изменяемого списка (таблица)

Sub Макрос2()

With ActiveSheet

.ListObjects.Add(xlSrcRange, .Range(«$A$8:$AR$» & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = _

«Список1»

End With

End Sub

Проверка на пустое значение

IsNull(выражение) — проверка на пустое значение

Пересечение ячеек

Sub Test()

  With ActiveWorkbook

   Worksheets(«Лист1»).Activate

   Dim Range1 As Range

   Set Range1 = Range(«A1:A8 A8:D8»)

   Range1.Value = «test»

  End With

End Sub

Умножение выделенного диапазона на 2

Sub Test()

Dim cur_range As Range

 With ActiveSheet

 Set cur_range = Selection

 cur_range.Activate

 For x = 1 To cur_range.Rows.Count

  For y = 1 To cur_range.Columns.Count

  ‘ значению ячейки присвоить значение умноженно на 2

  cur_range(x, y) = cur_range(x, y).Value * 2

  Next y

 Next x

 End With

End Sub

Одновременное умножение всех данных диапазона

Sub MultAllCells()

   Dim dblMult As Double

   Dim cell As Range

   ‘ Ввод коэффициента для умножения

   dblMult = InputBox(«Введите коэффициент, на который следует умножать»)

   ‘ Умножение содержимого на введенный коэффициент

   For Each cell In Selection

      If IsNumeric(cell.Value) And cell.Value <> «» Then

         ‘ Умножаются только ячейки, содержащие числовые данные

         cell.Value = cell.Value * dblMult

      Else

         MsgBox «В ячейке » & cell.Address & » нечисловое значение»

      End If

   Next

End Sub

Деление диапазона на 100

Sub Test23()

Dim iRange As Range

Dim kRange As Range

i = 1

j = 1

m = 5

n = 2

Set iRange = Range(Cells(i, j), Cells(m, n))

For Each kRange In iRange

kRange.Value = kRange.Value / 100

Next

End Sub

Возведение каждой ячейки диапазона в квадрат

Суммирование данных только видимых ячеек

Function СуммаВид(Диапазон) As Double

   ‘ Просмотр всех ячеек заданного диапазона

   For Each Ячейка In Диапазон

      ‘ Анализ только видимых ячеек

      If Not Ячейка.EntireRow.Hidden And Not _

       Ячейка.EntireColumn.Hidden Then

         ‘ При расчете учитываются только ячейки _

          с численными значениями

         If IsNumeric(Ячейка) = True Then

            СуммаВид = СуммаВид + Ячейка

         End If

      End If

   Next

End Function

Сумма ячеек с числовыми значениями

Sub CalculateSum()

   Dim i As Integer

   Dim intSum As Integer

   ‘ Расчет суммы ячеек столбца «A» (с первой по пятую)

   For i = 1 To 5

      If IsNumeric(Cells(i, 1)) Then

         intSum = intSum + Cells(i, 1)

      End If

   Next

   MsgBox «Сумма ячеек: » & intSum

End Sub

При суммировании — курсор внутри диапазона

Function Сумма(Диапазон, АдресЯчейки) As Double

   ‘ Просмотр всех ячеек диапазона

   For Each Ячейка In Диапазон

      ‘ Проверка, чтобы в суммировании не участвовала _

       ячейка с формулой

      If АдресЯчейки.Address <> Ячейка.Address Then

         ‘ В суммировании участвуют только ячейки _

          с численными значениями

         If IsNumeric(Ячейка) = True Then

            Сумма = Сумма + Ячейка

         End If

      End If

   Next

End Function

Начисление процентов в зависимости от суммы_1

Function dhCalculatePercent(lngSum As ****) As Double

   ‘ Процентные ставки (декларация констант)

   Const dblRate1 As Double = 0.09

   Const dblRate2 As Double = 0.11

   Const dblRate3 As Double = 0.15

   ‘ Граничные суммы вкладов (декларация констант)

   Const intSum1 As **** = 5000

   Const intSum2 As **** = 10000

   ‘ Возвращаем сумму, умноженную на соответствующую ставку

   If lngSum < intSum1 Then

      dhCalculatePercent = lngSum * dblRate1

   ElseIf lngSum < intSum2 Then

      dhCalculatePercent = lngSum * dblRate2

   Else

      dhCalculatePercent = lngSum * dblRate3

   End If

End Function

Начисление процентов в зависимости от суммы_2

Function dhCalculatePercent(lngSum As ****) As Double

   ‘ Процентные ставки (декларация констант)

   Const dblRate1 As Double = 0.09

   Const dblRate2 As Double = 0.11

   Const dblRate3 As Double = 0.15

   ‘ Граничные суммы вкладов (декларация констант)

   Const intSum1 As **** = 5000

   Const intSum2 As **** = 10000

   ‘ Возвращаем сумму, умноженную на соответствующую ставку

   Select Case lngSum

      Case Is < intSum1

         dhCalculatePercent = lngSum * dblRate1

      Case Is < intSum2

         dhCalculatePercent = lngSum * dblRate2

      Case Else

         dhCalculatePercent = lngSum * dblRate3

   End Select

End Function

Начисление процентов в зависимости от суммы_3

Function dhCalculatePercent(Sales As ****, IsTemporal As Boolean) As Double

   ‘ Процентные ставки (декларация констант)

   Const dblRate1 As Double = 0.09

   Const dblRate2 As Double = 0.11

   Const dblRate3 As Double = 0.15

   Const dblAdd As Double = 1.1

   ‘ Граничные суммы

   Const lngSum1 As **** = 5000

   Const lngSum2 As **** = 10000

   ‘ Расчет суммы для выплаты (как обычно)

   If Sales < lngSum1 Then

      dhCalculatePercent = Sales * dblRate1

   ElseIf Sales < lngSum2 Then

      dhCalculatePercent = Sales * dblRate2

   Else

      dhCalculatePercent = Sales * dblRate3

   End If

   If IsTemporal Then

      ‘ Для сторонних вкладчиков — надбавка

      dhCalculatePercent = dblAdd * dhCalculatePercent

   End If

End Function

Сводный пример расчета комиссионного вознаграждения

Function dhCalculateCom(dblSales As Double) As Double

   Const dblRate1 = 0.09

   Const dblRate2 = 0.11

   Const dblRate3 = 0.15

   ‘ Расчет комиссионных с продаж (без выслуги) в зависимости _

    от суммы

   Select Case dblSales

      Case 0 To 4999.99: dhCalculateCom = dblSales * dblRate1

      Case 5000 To 9999.99: dhCalculateCom = dblSales * dblRate2

      Case Is >= 10000: dhCalculateCom = dblSales * dblRate3

   End Select

End Function

Function dhCalculateCom2(dblSales As Double, intYears As Double) _

 As Double

   Const dblRate1 = 0.09

   Const dblRate2 = 0.11

   Const dblRate3 = 0.15

   ‘ Расчет комиссионных с продаж (без учета выслуги лет) _

    в зависимости от суммы

   Select Case dblSales

      Case 0 To 4999.99: dhCalculateCom2 = dblSales * dblRate1

      Case 5000 To 9999.99: dhCalculateCom2 = dblSales * dblRate2

      Case Is >= 10000: dhCalculateCom2 = dblSales * dblRate3

   End Select

   ‘ Надбавка за выслугу лет

   dhCalculateCom2 = dhCalculateCom2 + _

    (dhCalculateCom2 * intYears / 100)

End Function

Sub ComCalculator()

   Dim strMessage As String

   Dim dblSales As Double

   Dim ан As Integer

Calc:

   ‘ Отображение окна для ввода данных

   dblSales = Val(InputBox(«Сумма реализации:», _

    «Расчет комиссионного вознаграждения»))

   ‘ Формирование сообщения (с одновременным расчетом _

    вознаграждения)

   strMessage = «Объем продаж:» & vbTab & Format(dblSales, «$#,##0») & _

    vbCrLf & «Сумма вознаграждения:» & vbTab & _

    Format(dhCalculateCom(dblSales), «$#,##0») & _

    vbCrLf & vbCrLf & «Считаем дальше?»

   ‘ Вывод окна с сообщением (о рассчитанной сумме и вопросом _

    о продолжении расчетов)

   If MsgBox(strMessage, vbYesNo, _

    «Расчет комиссионного вознаграждения») = vbYes Then

      ‘ Продолжение расчетов

      GoTo Calc

   End If

End Sub

Движение по диапазону

Sub FullShach()

For Each c In Range(addressdiap)

    If c.Value > yr1 Then

       c.Select

        With Selection.Interior

          .ColorIndex = 6

          .Pattern = xlSolid

        End With

       Selection.Font.ColorIndex = yrcolor1

       If c.Value > yr2 Then

       c.Select

       Selection.Font.ColorIndex = yrcolor2

            If c.Value > yr3 Then

            c.Select

            Selection.Font.ColorIndex = yrcolor3

            End If

       End If

    End If

Next c

End Sub

Сдвиг от выделенной ячейки

Sub Test()

 Dim cur_range As Range

 Set cur_range = Range(«A1»)

 Set cur_range = cur_range.Offset(1, 0)

 Debug.Print cur_range.Address

End Sub

Перебор ячеек вниз по колонне

Sub beg()

Dim a As Boolean

Dim d As Double

Dim c As Range

a = False

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

While (a = False)

ActiveCell.Offset(1, 0).Select

If (IsEmpty(ActiveCell.Value) = False) Then

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

Else

a = False

End If

Wend

End Sub

Создание заливки диапазона

Sub FillRange()

   ‘ Заливка диапазона

   With Range(«B1:E10»)

      ‘ Задаем узор — сетчатый

      .Interior.Pattern = xlPatternChecker

      ‘ Цвет узора — синий

      .Interior.PatternColor = RGB(0, 0, 255)

      ‘ Цвет ячейки — красный

      .Interior.Color = RGB(255, 0, 0)

   End With

End Sub

Подбор параметра ячейки

Sub Макрос1()

‘ Сочетание клавиш: Ctrl+ф

    Range(«G5»).GoalSeek Goal:=4, ChangingCell:=Range(«G4»)

End Sub

Разбиение диапазона

Function ExtractElement(Txt, n, Separator) As String

‘   Функция выдает n-ый элемент текстовой строки Txt, где

‘   символ Separator используется как разделитель

    Dim Txt1 As String, TempElement As String

    Dim ElementCount As Integer, i As Integer

    Txt1 = Txt

‘   Если в качестве разделителя используется пробел, то убираем лишние

‘   и двойные пробелы

    If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1)

‘   Добавляем разделитель в конец строки (если необходимо)

    If Right(Txt1, 1) <> Separator Then Txt1 = Txt1 & Separator

‘   Начальные значения

    ElementCount = 0

    TempElement = «»

‘   Извлекаем элемент

    For i = 1 To Len(Txt1)

        If Mid(Txt1, i, 1) = Separator Then

            ElementCount = ElementCount + 1

            If ElementCount = n Then

‘               Found it, so exit

                ExtractElement = TempElement

                Exit Function

            Else

                TempElement = «»

            End If

        Else

            TempElement = TempElement & Mid(Txt1, i, 1)

        End If

    Next i

    ExtractElement = «»

End Function

Закройте редактор и вернитесь в Excel командой File — Close and return to Microsoft Excel.

Теперь в любой ячейке листа Вы можете использовать эту функцию через меню Вставка — Функция — категория Определенные пользователем, где в аргументах:

•          Txt — ячейка с текстом, который надо разделить,

•          n — порядковый номер извлекаемого элемента,

•          Separator — символ-разделитель.

Объединение данных диапазона

Function Couple(Diapazon)

   ‘ Объединение данных, содержащихся в ячейках диапазона _

    Diapazon (разделитель между значениями — пробел)

   ‘ iCell — текущая ячейка

   For Each iCell In Diapazon

      ‘ Сцепляются данные только заполненных ячеек

      If IsEmpty(iCell) <> True Then

         ‘ Добавление значения ячейки в выходную строку

         If Couple = «» Then

            Couple = iCell

         Else

            Couple = Couple & » » & iCell

         End If

      End If

   Next

End Function

Объединение данных диапазона_2

Function CoupleFormat(Diapazon)

   ‘ Объединение текстовых данных, содержащихся в ячейках _

    диапазона Diapazon (разделитель между значениями — пробел)

   ‘ iCell — текущая ячейка

   For Each iCell In Diapazon

      ‘ Сцепляются данные только заполненных ячеек

      If IsEmpty(iCell) <> True Then

         ‘ Добавление текста ячейки в выходную строку

         If CoupleFormat = «» Then

            CoupleFormat = iCell.Text

         Else

            CoupleFormat = CoupleFormat & » » & iCell.Text

         End If

      End If

   Next

End Function

Узнать максимальную колонку или строку.

Sub Test()

 With ActiveSheet

  Dim cur_range As Range

  Set cur_range = .UsedRange

  Debug.Print cur_range.Address

 End With

End Sub

Ограничение возможных значений диапазона

Sub Worksheet_Change(ByVal Target As Excel.Range)

   Dim rgInputRange As Range

   Dim cell As Range

   Dim strMessage As String

   Dim varResult As Variant

   ‘ Диапазон, в котором контролируется ввод

   Set rgInputRange = Range(«A1:E10»)

   ‘ Просмотр всех измененных ячеек и контроль ввода в тех, которые _

    принадлежат заданному диапазону

   For Each cell In Target

      ‘ Проверка принадлежности диапазону

      If Union(cell, rgInputRange).Address = rgInputRange.Address Then

         ‘ Контроль правильности ввода

         varResult = IsCellDataValid(cell)

         If varResult = True Then

            ‘ Введено корректное значение

            Exit Sub

         Else

         ‘ Формирование и вывод сообщения об ошибке

         strMessage = «Ячейка » & cell.Address(False, False) & «:» _

          & vbCrLf & vbCrLf & varResult

         MsgBox strMessage, vbCritical, «Неправильное значение»

         ‘ Очистка ввода

         Application.EnableEvents = False

         cell.ClearContents

         cell.Activate

         Application.EnableEvents = True

         End If

      End If

   Next cell

End Sub

Function IsCellDataValid(cell As Range) As Variant

   ‘ Возвращает True, если в ячейку вводится целое число _

    в диапазоне от 1 до 12. В противном случае выдается _

    соответствующее сообщение

   ‘ Проверка, является ли содержимое ячейки числом

   If Not WorksheetFunction.IsNumber(cell.Value) Then

      IsCellDataValid = «Нечисловое значение»

      Exit Function

   End If

   ‘ Проверка, является ли введенное число целым

   If Int(cell.Value) <> cell.Value Then

      IsCellDataValid = «Введите целое число»

      Exit Function

   End If

   ‘ Проверка соответствия числа диапазону

   If cell.Value < 1 Or cell.Value > 12 Then

      IsCellDataValid = «Значение должно быть от 1 до 12»

      Exit Function

   End If

   ‘ В ячейку введено допустимое значение

   IsCellDataValid = True

End Function

Тестирование скорости чтения и записи диапазонов

Sub TableSpeedTest()

   Dim alngData() As ****        ‘ Массив с числами

   Dim lngCount As ****          ‘ Количество элементов в массиве

   Dim dtStart As Date           ‘ Хранит время (и даже дату) начала _

                                  тестирования

   Dim strArrayToTable As String ‘ Время записи в таблицу

   Dim strTableToArray As String ‘ Время чтения из таблицы

   Dim strMessage As String

   Dim i As ****

   ‘ Подготовка диапазона ячеек

   Range(«A:A»).ClearContents

   ‘ Ввод размера массива, формирование массива заданного размера

   lngCount = InputBox(«Введите количество элементов»)

   ReDim alngData(1 To lngCount)

   ‘ Заполнение массива данными

   For i = 1 To lngCount

      alngData(i) = i

   Next i

   ‘ Перенос массива в таблицу

   Application.ScreenUpdating = False

   dtStart = Timer

   For i = 1 To lngCount

      Cells(i, 1) = i

   Next i

   strArrayToTable = Format(Timer — dtStart, «00:00»)

   ‘ Чтение данных из таблицы обратно в массив

   dtStart = Timer

   For i = 1 To lngCount

      alngData(i) = Cells(i, 1)

   Next i

   strTableToArray = Format(Timer — dtStart, «00:00»)

   Application.ScreenUpdating = True

   ‘ Вывод на экран результатов тестирования

   strMessage = «Запись: » & strArrayToTable & vbCrLf & _

    «Чтение: » & strTableToArray

   MsgBox strMessage, , lngCount & » элементов»

End Sub

Открыть MsgBox при выборе ячейки

Private Sub Worksheet_Selectiоnchange(ByVal Target As Range)

If Target.Address = «$A$1» Then MsgBox «Hello world»

End Sub

Скрытие строки

Sub HideString()

   Rows(2).Hidden = True

End Sub

Скрытие нескольких строк

Sub HideStrings()

   Rows(«3:5»).Hidden = True

End Sub

Скрытие столбца

Sub HideCollumn()

   Columns(2).Hidden = True

End Sub

Скрытие нескольких столбцов

Sub HideCollumns()

   Columns(«E:F»).Hidden = True

End Sub

Скрытие строки по имени ячейки

Sub HideCell()

   Range(«Секрет»).EntireRow.Hidden = True

End Sub

Скрытие нескольких строк по адресам ячеек

Sub HideCell()

   Range(«B3:D4»).EntireRow.Hidden = True

End Sub

Скрытие столбца по имени ячейки

Sub HideCell()

   Range(«Секрет»).EntireColumn.Hidden = True

End Sub

Скрытие нескольких столбцов по адресам ячеек

Sub HideCell()

   Range(«C2:D5»).EntireColumn.Hidden = True

End Sub

Мигание ячейки

Sub BlinkingCell()

   Static intCalls As Integer  ‘ Счетчик количества миганий

   ‘ Если ячейка мигала менее 10 раз, то изменим _

    в очередной раз ее цвет

   If intCalls < 10 Then

      intCalls = intCalls + 1

      ‘ Определение, какой цвет необходимо установить

      If Range(«A1»).Interior.Color <> RGB(255, 0, 0) Then

         ‘ Цвет ячейки не красный, так что теперь назначим _

          именно красный цвет

         Range(«A1»).Interior.Color = RGB(255, 0, 0)

      Else

         ‘ Назначим ячейке зеленый цвет

         Range(«A1»).Interior.Color = RGB(0, 255, 0)

      End If

      ‘ Эту процедуру необходимо вызвать через 5 секунд

      Application.OnTime Now + TimeValue(«00:00:05»), «BlinkingCell»

   Else

      ‘ Хватит мигать

      Range(«A1»).Interior.ColorIndex = xlNone

      intCalls = 0

   End If

End Sub

ГЛАВА 4. РАБОТА С ПРИМЕЧАНИЯМИ

Вывод на экран всех примечаний рабочего листа

Sub ShowComments()

   Dim cell As Range

   Dim rgCells As Range

   ‘ Получение всех ячеек с примечаниями

   Set rgCells = Selection.SpecialCells(xlComments)

   If rgCells Is Nothing Then

      ‘ Примечаний нет

      Exit Sub

   End If

   ‘ Проходим по всем ячейкам диапазона

   For Each cell In rgCells

      ‘ Вывод примечаний в соседнюю ячейку

      cell.Next.Value = cell.Comment.Text

   Next

End Sub

Функция извлечения комментария

Function GetCommentText(rCommentCell As Range)

Dim strGotIt As String

On Error Resume Next

strGotIt = WorksheetFunction.Clean _

(rCommentCell.Comment.Text)

GetCommentText = strGotIt

On Error GoTo 0

End Function

вставить в модуль эксель

Список примечаний защищенных листов

Sub ShowComments1()

   Dim cell As Range

   Dim strFirstAddress As String

   Dim strComments As String

   ‘ Получаем все ячейки выделения, в которых есть комментарий

   Set cell = Selection.Find(«*», LookIn:=xlComments)

   If Not cell Is Nothing Then

      ‘ Сохранение адреса первой найденной ячейки _

       (для предотвращения зацикливания поиска)

      strFirstAddress = cell.Address

      Do

         ‘ Добавление текста примечания в выходную строку

         strComments = strComments & «Комментарий: » & _

          cell.Comment.Text & Chr(13)

         ‘ Продолжение поиска

         Set cell = Selection.FindNext(cell)

      Loop While Not cell Is Nothing And _

       cell.Address <> strFirstAddress

   End If

   If strComments <> «» Then

      ‘ Отображение окна с текстом примечаний

      MsgBox strComments

   Else

      MsgBox «В выделенной ячейке/ячейках комментариев нет»

   End If

End Sub

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

Sub ListOfComments()

   Dim cell As Range

   Dim rgCells As Range

   Dim intRow As Integer

   ‘ Получение всех ячеек с примечаниями

   On Error Resume Next

   Set rgCells = Selection.SpecialCells(xlComments)

   If rgCells Is Nothing Then

      ‘ Примечаний нет

      Exit Sub

   End If

   ‘ Проходим по всем ячейкам диапазона

   For Each cell In rgCells

      ‘ Вывод примечаний в ячейку столбца «C»

      intRow = intRow + 1

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

   Next

End Sub

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

Sub ListOfComments1()

   Dim cell As Range

   Dim strFirstAddress As String

   Dim intRow As Integer

   ‘ Получение всех ячеек выделения, в которых есть примечания

   Set cell = Cells.Find(«*», LookIn:=xlComments)

   If Not cell Is Nothing Then

      ‘ Сохранение адреса первой найденной ячейки _

       (для предотвращения зацикливания поиска)

      strFirstAddress = cell.Address

      Do

         ‘ Вывод текста в столбец «C»

         intRow = intRow + 1

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

         ‘ Продолжение поиска

         Set cell = Cells.FindNext(cell)

         Loop While Not cell Is Nothing And _

          cell.Address <> strFirstAddress

   End If

End Sub

Перечень примечаний в отдельном списке_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

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

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 ****

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 ****

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

ГЛАВА 5 . ПОЛЬЗОВАТЕЛЬСКИЕ ВКЛАДКИ НА ЛЕНТЕ

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

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

Создание списка пунктов главного меню Excel

Листинг 3.90. Список содержимого главного меню

Sub ListOfMenues()

   Dim intRow As Integer    ‘ Текущая строка, куда идет запись

   Dim cbrcMenu As CommandBarControl        ‘ Главное меню

   Dim cbrcSubMenu As CommandBarControl     ‘ Подменю

   Dim cbrcSubSubMenu As CommandBarControl  ‘ Подменю в подменю

   ‘ Очищаем ячейки текущего листа

   Cells.Clear

   ‘ Начинаем запись с первой строки

   intRow = 1

   ‘ Просматриваем все элементы строки меню

   On Error Resume Next    ‘ Игнорируем ошибки

   For Each cbrcMenu In CommandBars(1).Controls

      ‘ Просматриваем элементы выпадающего меню cbrcMenu

      For Each cbrcSubMenu In cbrcMenu.Controls

         ‘ Просматриваем элементы подменю cbrcSubMenu

         For Each cbrcSubSubMenu In cbrcSubMenu.Controls

            ‘ Выводим название главного меню

            Cells(intRow, 1) = cbrcMenu.Caption

            ‘ Выводим название подменю

            Cells(intRow, 2) = cbrcSubMenu.Caption

            ‘ Выводим название вложенного подменю

            Cells(intRow, 3) = cbrcSubSubMenu.Caption

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

            intRow = intRow + 1

         Next cbrcSubSubMenu

      Next cbrcSubMenu

   Next cbrcMenu

End Sub

Создание списка пунктов контекстных меню

Листинг 3.91. Список содержимого контекстных меню

Sub ListOfContextMenues()

   Dim intRow As ****

   Dim intControl As Integer

   Dim cbrBar As CommandBar

   ‘ Очистка ячеек активного листа

   Cells.Clear

   ‘ Начинаем вывод с первой строки

   intRow = 1

   ‘ Просмотр списка контекстных меню и вывод информации о них

   For Each cbrBar In CommandBars

      If cbrBar.Type = msoBarTypePopup Then

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

         Cells(intRow, 1) = cbrBar.Index

         ‘ Название

         Cells(intRow, 2) = cbrBar.Name

         ‘ Просмотр всех элементов контекстного меню и вывод _

          названий этих элементов в ячейки текущей строки

         For intControl = 1 To cbrBar.Controls.Count

            Cells(intRow, intControl + 2) = _

             cbrBar.Controls(intControl).Caption

         Next intControl

         ‘ Переход на следующую строку таблицы

         intRow = intRow + 1

      End If

   Next cbrBar

   ‘ Делаем ширину ячеек таблицы оптимальной для просмотра

   Cells.EntireColumn.AutoFit

End Sub

Отображение панели инструментов при определенном условии

Листинг 3.92. Код в модуле рабочего листа

Sub Worksheet_Selectiоnchange(ByVal Target As Excel.Range)

   ‘ Проверка условия отображения

   If Union(Target, Range(«A1:D5»)).Address = _

    Range(«A1:D5»).Address Then

      ‘ Условие выполнено — можно показывать панель

      CommandBars(«AutoSense»).Visible = True

   Else

      ‘ Условие не выполнено — панель нужно скрыть

      CommandBars(«AutoSense»).Visible = False

   End If

End Sub

Листинг 3.93. Код в стандартном модуле

Sub CreatePanel()

   Dim cbrBar As CommandBar

   Dim button As CommandBarButton

   Dim i As Integer

   ‘ Удаление одноименной панели (при ее наличии)

   On Error Resume Next

   CommandBars(«AutoSense»).Delete

   On Error GoTo 0

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

   Set cbrBar = CommandBars.Add

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

   For i = 1 To 4

      Set button = cbrBar.Controls.Add(msoControlButton)

      With button

         .OnAction = «Buttоnclick» & i

         .FaceId = i + 37

      End With

   Next i

   cbrBar.Name = «AutoSense»

End Sub

Sub Buttоnclick3()

   ‘ Перемещение вниз

   On Error Resume Next

   ActiveCell.Offset(1, 0).Activate

End Sub

Sub Buttоnclick1()

   ‘ Перемещение вверх

   On Error Resume Next

   ActiveCell.Offset(-1, 0).Activate

End Sub

Sub Buttоnclick2()

   ‘ Перемещение вправо

   On Error Resume Next

   ActiveCell.Offset(0, 1).Activate

End Sub

Sub Buttоnclick4()

   ‘ Перемещение влево

   On Error Resume Next

   ActiveCell.Offset(0, -1).Activate

End Sub

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

Листинг 3.94. Управление отображением панелей инструментов

Sub HidePanels()

   Dim cbrBar As CommandBar

   Dim intRow As Integer       ‘ Номер текущей строки листа

   ‘ Отключение обновления экрана

   Application.ScreenUpdating = False

   ‘ Подготовка к сохранению

   Cells.Clear

   ‘ Скрытие видимых панелей и сохранение их названий

   intRow = 1       ‘ Запись имен с первой строки

   For Each cbrBar In CommandBars

      If cbrBar.Type = msoBarTypeNormal Then

         If cbrBar.Visible Then

            cbrBar.Visible = False

            Cells(intRow, 1) = cbrBar.Name

            intRow = intRow + 1

         End If

      End If

   Next

   ‘ Включение обновления экрана

   Application.ScreenUpdating = True

End Sub

Sub ShowPanels()

   Dim cell As Range       ‘ Текущая ячейка листа

   ‘ Отключение обновления экрана

   Application.ScreenUpdating = False

   ‘ Отображение скрытых панелей

   On Error Resume Next

   For Each cell In Range(«A:A»).SpecialCells( _

    xlCellTypeConstants)

      CommandBars(cell.Value).Visible = True

   Next cell

   ‘ Включение обновления экрана

   Application.ScreenUpdating = True

End Sub

Создать подсказку к моим кнопкам

‘ Cоздаем тулбар

Рublic Sub InitToolBar()

Dim cmdbarSM As CommandBar

Dim ctlNewBtn As CommandBarButton

  Set cmdbarSM = CommandBars.Add(Name:=»MyToolBar»,

                                 Position:=msoBarFloating, _

                                 temporary:=True)

  With cmdbarSM

    ‘ 1) Добавляем кнопку

    Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

    With ctlNewBtn

      . FaceId = 26

      .OnAction = «OnButton1_Click»

     .TooltipText = «My tooltip message!»

    End With

    ‘ 2) Добавляем ещё кнопку

    Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

    With ctlNewBtn

      .FaceId = 44

      .OnAction = «OnButton2_Click»

     .TooltipText = «Another tooltip message!»

    End With

    .Visible = True

  End With

End Sub

Создание меню на основе данных рабочего листа

Листинг 3.95. Код в модуле ЭтаКнига

Sub Workbook_Open()

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

   Call CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

   Call DeleteCustomMenu

End Sub

Листинг 3.96. Код в стандартном модуле

Sub CreateMenu()

   Dim sheet As Worksheet          ‘ Лист с описанием меню

   Dim intRow As Integer           ‘ Считываемая строка

   Dim cbrpBar As CommandBarPopup  ‘ Выпадающее меню

   Dim objNewItem As Object        ‘ Элемент меню cbrpBar

   Dim objNewSubItem As Object     ‘ Элемент подменю objNewItem

   Dim intMenuLevel As Integer     ‘ Уровень вложенности пункта меню

   Dim strCaption As String        ‘ Название пункта меню

   Dim strAction As String         ‘ Макрос пункта меню

   Dim fIsDevider As Boolean       ‘ Нужен разделитель

   Dim intNextLevel As Integer     ‘ Уровень вложенности следующего _

                                    пункта меню

   Dim strFaceID As String         ‘ Номер значка пункта меню

   ‘ Расположение данных для меню

   Set sheet = ThisWorkbook.Sheets(«ЛистМеню»)

   ‘ Удаление одноименного меню (при его наличии)

   Call DeleteMenu

   ‘ Данные считываем со второй строки

   intRow = 2

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

   Do Until IsEmpty(sheet.Cells(intRow, 1))

      ‘ Считываем информацию о пункте меню

      With sheet

         ‘ Уровень вложенности

         intMenuLevel = .Cells(intRow, 1)

         ‘ Название

         strCaption = .Cells(intRow, 2)

         ‘ Название макроса для меню

         strAction = .Cells(intRow, 3)

         ‘ Нужен ли разделитель перед меню?

         fIsDevider = .Cells(intRow, 4)

         ‘ Номер стандартного значка (если значок нужен)

         strFaceID = .Cells(intRow, 5)

         ‘ Уровень вложенности следующего меню

         intNextLevel = .Cells(intRow + 1, 1)

      End With

      ‘ Создаем меню в зависимости от уровня его вложенности

      Select Case intMenuLevel

         Case 1

            ‘ Создаем меню

            Set cbrpBar = Application.CommandBars(1). _

             Controls.Add(Type:=msoControlPopup, _

             Before:=strAction, _

             Temporary:=True)

            cbrpBar.Caption = strCaption

         Case 2

            ‘ Создаем элемент меню

            If intNextLevel = 3 Then

               ‘ Следующий элемент вложен в создаваемый, то есть _

                создаем раскрывающееся подменю

               Set objNewItem = _

                cbrpBar.Controls.Add(Type:=msoControlPopup)

            Else

               ‘ Создаем команду меню

               Set objNewItem = _

                cbrpBar.Controls.Add(Type:=msoControlButton)

               objNewItem.OnAction = strAction

            End If

            ‘ Установка названия нового пункта меню

            objNewItem.Caption = strCaption

            ‘ Установка значка нового пункта меню (если нужно)

            If strFaceID <> «» Then

               objNewItem.FaceId = strFaceID

            End If

            ‘ Если нужно, то добавим разделитель

            If fIsDevider Then

               objNewItem.BeginGroup = True

            End If

         Case 3

            ‘ Создание элемента подменю

            Set objNewSubItem = _

             objNewItem.Controls.Add(Type:=msoControlButton)

            ‘ Установка его названия

            objNewSubItem.Caption = strCaption

            ‘ Назначение макроса (или команды)

            objNewSubItem.OnAction = strAction

            ‘ Установка значка (если нужно)

            If strFaceID <> «» Then

              objNewSubItem.FaceId = strFaceID

            End If

            ‘ Если нужно, то добавим разделитель

            If fIsDevider Then

               objNewSubItem.BeginGroup = True

            End If

      End Select

      ‘ Переход на следующую строку таблицы

      intRow = intRow + 1

   Loop

End Sub

Sub DeleteMenu()

   Dim sheet As Worksheet    ‘ Лист с описанием меню

   Dim intRow As Integer     ‘ Считываемая строка

   Dim strCaption As String  ‘ Название меню

   Set sheet = ThisWorkbook.Sheets(«ЛистМеню»)

   ‘ Данные начинаются со второй строки

   intRow = 2

   ‘ Считываем данные, пока есть значения в столбце «A», _

    и удаляем созданные ранее меню (с уровнем вложенности 1)

   On Error Resume Next

   Do Until IsEmpty(sheet.Cells(intRow, 1))

      If sheet.Cells(intRow, 1) = 1 Then

         strCaption = sheet.Cells(intRow, 2)

         Application.CommandBars(1).Controls(strCaption).Delete

      End If

      intRow = intRow + 1

   Loop

   On Error GoTo 0

End Sub

Создание контекстного меню

Листинг 3.97. Код в модуле рабочего листа

Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _

 Cancel As Boolean)

   ‘ Проверка, попадает ли выделенная ячейка в диапазон

   If Union(Target.Range(«A1»), Range(«A2:D5»)).Address = _

    Range(«A2:D5»).Address Then

      ‘ Показываем свое контекстное меню

      CommandBars(«MyContextMenu»).ShowPopup

      Cancel = True

   End If

End Sub

Листинг 3.98. Код в модуле ЭтаКнига

Sub Workbook_Open()

   ‘ Создание контекстного меню при открытии книги

   Call CreateCustomContextMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

   Call DeleteCustomContextMenu

End Sub

Код в стандартном модуле

Sub CreateCustomContextMenu()

   ‘ Удаление одноименного меню

   Call DeleteCustomContextMenu

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

   With CommandBars.Add(«MyContextMenu», msoBarPopup, , True).Controls

      ‘ Создание и настройка кнопок меню

      ‘ Кнопка «Числовой формат»

      With .Add(msoControlButton)

         .Caption = «&Числовой формат…»

         .OnAction = «ShowFormatNumber»

         .FaceId = 1554

      End With

      ‘ Кнопка «Выравнивание»

      With .Add(msoControlButton)

         .Caption = «&Выравнивание…»

         .OnAction = «ShowFormatAlignment»

         .FaceId = 217

      End With

      ‘ Кнопка «Шрифт»

      With .Add(msoControlButton)

         .Caption = «&Шрифт…»

         .OnAction = «ShowFormatFont»

         .FaceId = 291

      End With

      ‘ Кнопка «Границы»

      With .Add(msoControlButton)

         .Caption = «&Границы…»

         .OnAction = «ShowFormatBorder»

         .FaceId = 149

         .BeginGroup = True

      End With

      ‘ Кнопка «Узор»

      With .Add(msoControlButton)

         .Caption = «&Узор…»

         .OnAction = «ShowFormatPatterns»

         .FaceId = 1550

      End With

      ‘ Кнопка «Защита»

      With .Add(msoControlButton)

         .Caption = «&Защита…»

         .OnAction = «ShowFormatProtection»

         .FaceId = 2654

      End With

   End With

End Sub

Блокировка контекстного меню

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

   Static intCount As Integer     ‘ Счетчик нажатий кнопки мыши

   Dim x As Integer, y As Integer

   ‘ Блокировать обработку щелчка правой кнопкой мыши

   Cancel = True

   ‘ Отображение текстового поля с количеством щелчков правой _

    кнопкой мыши

   x = Target.Left

   y = Target.Top

   intCount = intCount + 1

   ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _

    x, y, 35, 20).TextFrame.Characters.Text = intCount

End Sub

Добавление команды в меню Сервис

Sub AddMenuItem()

   Dim cbrpMenu As CommandBarPopup

   ‘ Удаление аналогичной команды (при ее наличии)

   Call DeleteMenuItem

   ‘ Получение доступа к меню «Сервис»

   Set cbrpMenu = CommandBars(1).FindControl(ID:=30007)

   If cbrpMenu Is Nothing Then

      ‘ Не удалось получить доступ

      MsgBox «Невозможно добавить элемент.»

      Exit Sub

   Else

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

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

         ‘ Название команды

         .Caption = «Очистить в&се, кроме формул»

         ‘ Значок

         .FaceId = 348

         ‘ Сочетание клавиш (только надпись на кнопке)

         .ShortcutText = «Ctrl+Shift+C»

         ‘ Сопоставленный макрос

         .OnAction = «ExecuteCommand»

         ‘ Добавление разделителя перед командой

         .BeginGroup = True

      End With

   End If

   ‘ Сопоставление с макросом сочетания клавиш Ctrl+Shift+C

   Application.MacroOptions _

    Macro:=»ExecuteCommand», _

    HasShortcutKey:=True, _

    ShortcutKey:=»C»

End Sub

Sub ExecuteCommand()

   ‘ Очистка содержимого всех ячеек (кроме формул)

   On Error Resume Next

   Cells.SpecialCells(xlCellTypeConstants, 23).ClearContents

End Sub

Sub DeleteMenuItem()

   ‘ Удаление команды из меню

   On Error Resume Next

   CommandBars(1).FindControl(ID:=30007). _

    Controls(«Очистить в&се, кроме формул»).Delete

End Sub

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

Листинг 3.110. Код в стандартном модуле

Dim AppObject As New Class1

Sub AddCommand()

   Dim cbrpBar As CommandBarPopup

   ‘ Удаление аналогичной команды (при ее наличии)

   Call DeleteCommand

   ‘ Получение доступа к меню «Вид»

   Set cbrpBar = CommandBars(1).FindControl(ID:=30004)

   If cbrpBar Is Nothing Then

      ‘ Не удалось получить доступ к меню

      MsgBox «Невозможно добавить элемент меню.»

      Exit Sub

   Else

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

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

         .Caption = «&Линии сетки»

         .OnAction = «GhangeGridlinesState»

      End With

   End If

   ‘ Даем объекту AppObject обрабатывать события

   Set AppObject.AppEvents = Application

End Sub

Sub DeleteCommand()

   ‘ Удаление каманды из меню (если она там есть)

   On Error Resume Next

   CommandBars(1).FindControl(ID:=30004). _

    Controls(«&Линии сетки»).Delete

End Sub

Sub GhangeGridlinesState()

   ‘ Изменение состояния отображения линий сетки _

    на противоположное (если нет — покажем, если есть — скроем)

   If TypeName(ActiveSheet) = «Worksheet» Then

      ActiveWindow.DisplayGridlines = _

       Not ActiveWindow.DisplayGridlines

      ‘ Установка или снятие флажка в меню

      Call CheckGridlines

   End If

End Sub

Sub CheckGridlines()

   Dim button As CommandBarButton

   On Error Resume Next

   ‘ Поиск команды «Линии сетки» в меню «Вид»

   Set button = CommandBars(1).FindControl(ID:=30004). _

    Controls(«&Линии сетки»)

   ‘ Изменение состояния флажка на противоположное

   If ActiveWindow.DisplayGridlines Then

      ‘ Установка

      button.State = msoButtonDown

   Else

      ‘ Снятие

      button.State = msoButtonUp

   End If

End Sub

Создание панели со списком

Sub DeleteCustomContextMenu()

   ‘ Удаление меню

   On Error Resume Next

   CommandBars(«MyContextMenu»).Delete

End Sub

Sub ShowFormatNumber()

   ‘ Число

   Application.Dialogs(xlDialogFormatNumber).Show

End Sub

Sub ShowFormatAlignment()

   ‘ Выравнивание

   Application.Dialogs(xlDialogAlignment).Show

End Sub

Sub ShowFormatFont()

   ‘ Шрифт

   Application.Dialogs(xlDialogFormatFont).Show

End Sub

Sub ShowFormatBorder()

   ‘ Граница

   Application.Dialogs(xlDialogBorder).Show

End Sub

Sub ShowFormatPatterns()

   ‘ Вид (Узор)

   Application.Dialogs(xlDialogPatterns).Show

End Sub

Sub ShowFormatProtection()

   ‘ Защита

   Application.Dialogs(xlDialogCellProtection).Show

End Sub

Sub CreatePanel()

   Dim i As Integer

   On Error Resume Next

   ‘ Удаление одноименной панели (если есть)

   CommandBars(«Список месяцев»).Delete

   On Error GoTo 0

   ‘ Создание панели «Список месяцев»

   With CommandBars.Add

      .Name = «Список месяцев»

      ‘ Создание списка месяцев

      With .Controls.Add(Type:=msoControlDropdown)

         ‘ Настройка (имя, макрос, стиль)

         .Caption = «DateDD»

         .OnAction = «SetMonth»

         .Style = msoButtonAutomatic

         ‘ Добавление в список названий месяцев

         For i = 1 To 12

            .AddItem Format(DateSerial(1, i, 1), «mmmm»)

         Next i

         ‘ Выделение первого месяца

         .ListIndex = 1

      End With

      ‘ Показываем созданную панель

      .Visible = True

   End With

End Sub

Sub SetMonth()

   ‘ Перенос названия выделенного месяца в ячейку

   On Error Resume Next

   With CommandBars(«Список месяцев»).Controls(«DateDD»)

      ActiveCell.Value = .List(.ListIndex)

   End With

End Sub

Мультфильм с помощником в главной роли

Листинг 4.1. «Танцующий» помощник

Sub RunAssistantDance()

   Static intAction As Integer

   ‘ Заставляем помощника выполнять действие (всего 16)

   DoAssistantAction intAction

   intAction = intAction + 1

   If intAction < 16 Then

      ‘ Следующее действие через 3 секунды

      Application.OnTime Time + TimeValue(«00:00:3»), _

       «RunAssistantDance»

   End If

End Sub

Sub DoAssistantAction(intAction As Integer)

   Dim astAssistant As Assistant

   Set astAssistant = Application.Assistant

   ‘ Помещаем помощника в центр активного окна

   astAssistant.Top = Application.ActiveWindow.Top _

    + Application.ActiveWindow.Height / 2

   astAssistant.Left = Application.ActiveWindow.Left _

    + Application.ActiveWindow.Width / 2

   ‘ Показываем помощника

   astAssistant.On = True

   astAssistant.Visible = True

   ‘ Показываем заданное параметром intAction действие

   Select Case intAction

      Case 0

         astAssistant.Animation = msoAnimationAppear

      Case 1

         astAssistant.Animation = msoAnimationCheckingSomething

      Case 2

         astAssistant.Animation = msoAnimationBeginSpeaking

      Case 3

         astAssistant.Animation = msoAnimationCharacterSuccessMajor

      Case 4

         astAssistant.Animation = msoAnimationEmptyTrash

      Case 5

         astAssistant.Animation = msoAnimationGestureDown

      Case 5

         astAssistant.Animation = msoAnimationGestureLeft

      Case 6

         astAssistant.Animation = msoAnimationGestureRight

      Case 7

         astAssistant.Animation = msoAnimationGestureUp

      Case 8

         astAssistant.Animation = msoAnimationGetArtsy

      Case 9

         astAssistant.Animation = msoAnimationGetAttentionMajor

      Case 10

         astAssistant.Animation = msoAnimationGetAttentionMinor

      Case 11

         astAssistant.Animation = msoAnimationGetTechy

      Case 12

         astAssistant.Animation = msoAnimationGetWizardy

      Case 13

         astAssistant.Animation = msoAnimationGoodbye

      Case 14

         astAssistant.Animation = msoAnimationGreeting

      Case 15

         astAssistant.Animation = msoAnimationDisappear

   End Select

End Sub

Дополнение помощника текстом, заголовком, кнопкой и значком

Листинг 4.2. Настройка помощника

Sub AssistantMessage()

   Dim strTitle As String    ‘ Заголовок сообщения

   Dim strMessage As String  ‘ Текст сообщения

   ‘ Содержимое заголовка и текста в окне помощника

   strTitle = «Спрашивайте — ответим»

   strMessage = «{cf 249}{ul 1} Руки мыли{ul 0}?» _

    & vbCr & «{cf 6} Не забыть обновить антивирус!»

   ‘ Настраиваем помощника

   With Application.Assistant

      ‘ Включаем и показываем помощника

      .On = True

      .Visible = True

      ‘ Создаем окно сообщения

      With .NewBalloon

         .BalloonType = msoBalloonTypeButtons

         ‘ Кнопка «ОК» в окне помощника

         .button = msoButtonSetOK

         ‘ Значок в окне помощника

         .Icon = msoIconAlert

         ‘ Заголовок в окне помощника

         .Heading = strTitle

         ‘ Текст в окне помощника

         .Text = strMessage

         ‘ Отображение окна

         .Show

      End With

   End With

End Sub

Новые параметры помощника

Листинг 4.3. Новые параметры помощника

Sub AssistantCheckboxes()

   Dim i As Integer

   Dim strMessage As String

   With Assistant

      ‘ Включение и отображение помощника

      .On = True

      .Visible = True

      ‘ Создание окна сообщения

      With .NewBalloon

         ‘ Настройка окна…

         ‘ Тип окна

         .BalloonType = msoBalloonTypeButtons

         ‘ Заголовок

         .Heading = «Выберите страну»

         ‘ Добавление флажков

         .CheckBoxes(1).Text = «Россия»

         .CheckBoxes(2).Text = «США»

         .CheckBoxes(3).Text = «Южная Африка»

         .button = msoButtonSetOkCancel

         ‘ Отображение окна

         If .Show = msoBalloonButtonOK Then

            ‘ Вывод информационного окна в зависимости _

             от установленных флажков

            For i = 1 To 3

               If .CheckBoxes(i).Checked Then

                  strMessage = strMessage & _

                   .CheckBoxes(i).Text & vbCr

               End If

            Next

            ‘ Отображение окна сообщения (имеется в виду _

             стандартное окно)

            If Len(strMessage) = 0 Then

               MsgBox «No choice.»

            Else

               MsgBox strMessage

            End If

         End If

      End With

   End With

End Sub

Использование помощника для выбора цвета заливки

Листинг 4.4. Выбор цвета заливки рабочего листа

Sub AssistantChooseColor()

   Dim intChoise As Integer

   With Assistant

      ‘ Включение и отображение помощника

      .On = True

      .Visible = True

      With .NewBalloon

         ‘ Настройка окна…

         ‘ Тип

         .BalloonType = msoBalloonTypeButtons

         ‘ Заголовок

         .Heading = «Какой нужен цвет?»

         ‘ Первый цвет

         .Labels(1).Text = «Красный»

         ‘ Второй цвет

         .Labels(2).Text = «Желтый»

         ‘ Третий цвет

         .Labels(3).Text = «Зеленый»

         ‘ Тип кнопок

         .button = msoButtonSetNone

         ‘ Оображение окна

         intChoise = .Show

         ‘ Информационное сообщение о выбранном цвете

         MsgBox «Выбран: » & .Labels(intChoise).Text

      End With

   End With

   ‘ Настройка цветов ячеек (присвоение выбранного цвета)

   Select Case intChoise

      Case 1

         ‘ Красный цвет

         ActiveSheet.Cells.Interior.Color = RGB(255, 0, 0)

      Case 2

         ‘ Желтый цвет

         ActiveSheet.Cells.Interior.Color = RGB(255, 255, 0)

      Case 3

         ‘ Зеленый цвет

         ActiveSheet.Cells.Interior.Color = RGB(0, 255, 0)

   End Select

End Sub

ГЛАВА 6. ДИАЛОГОВЫЕ ОКНА

Функция INPUTBOX (через ввод значения)

Public Sub ИнпутБокс()

Dim текст As Variant

MsgBox «Если в InputBox нажать Отмена, в ячейке будут удалены все данные»

текст = InputBox(«Введите текст», «Окно ввода текста», «222»)

MsgBox текст

If текст <> «» Then

Range(«H7») = текст

MsgBox «Как сделать так, чтобы при выборе пользователем в InputBox — Отмена он закрывался и прекращалось выполнение процедуры?»

Else

Exit Sub

End If

End Sub

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

Sub Test()

 With Application.Workbooks.Item(«Test.xls»)

 Sheets(«Test»).PrintPreview

 End With

End Sub

Настройка ввода данных в диалоговом окне

Sub DialogInputData()

   Dim intMin As Integer, intMax As Integer ‘ Диапазон значений

   Dim strInput As String                   ‘ Введенная пользователем строка

   Dim strMessage As String

   Dim intValue As Integer

   intMin = 1    ‘ Минимальное значение

   intMax = 50   ‘ Максимальное значение

   strMessage = «Введите значение от » & intMin & » до » & intMax

   ‘ Ввод значения (цикл завершается, когда пользователь вводит _

    значение из заданного диапазона или отменяет ввод)

   Do

      strInput = InputBox(strMessage)

      If strInput = «» Then Exit Sub   ‘ Отмена ввода

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

      If IsNumeric(strInput) Then

         intValue = CInt(strInput)

         ‘ Проверка, удовлетворяет ли значение диапазону

         If intValue >= intMin And intValue <= intMax Then

            ‘ Все условия выполнены

            Exit Do

         End If

      End If

      ‘ Формирование сообщения с текстом ошибки

      strMessage = «Вы ввели некорректное значение.» & vbNewLine & _

       «Введите число от » & intMin & » до » & intMax

   Loop

   ‘ Внесение данных в ячейку

   ActiveSheet.Range(«A1»).Value = strInput

End Sub

Открытие диалогового окна (“Открыть файл”)_1

Sub Test()

  Application.Dialogs(xlDialogOpen).Show «*.dbf»

End Sub

Открытие диалогового окна (“Открыть файл”)_2

fileToOpen = Application.GetOpenFilename(«Text Files (*.txt), *.txt»)

If fileToOpen <> False Then

  MsgBox «Open » & fileToOpen

End If

Открытие диалогового окна (“Печать”)

Application.Dialogs(xlDialogPrint).Show

Другие диалоговые окна

xlDialogClear — очистка ячейки или диапазона

xlDialogDisplay — параметры отображения ячеек

xlDialogFileDelete — удаление файла

xlDialogSaveWorkbook — сохранить книгу

xlDialogSearch — поиск в документе

xlDialogWorkbookName — переименование листа

Вызов броузера из Экселя

Надо создать кнопку которой добавить код:

Sub Button1_Click()

            Call ShellExecute(GetDesktopWindow, «Open», «www.armentel.com/avb», «», «c:», SW_SHOWNORMAL)

End Sub

И функция:

            Private Declare Function ShellExecute& Lib «shell32.dll» Alias «ShellExecuteA» (ByVal hwnd As ****, ByVal _

            lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _

            ByVal nShowCmd As ****)

            Private Declare Function GetDesktopWindow Lib «user32» () As ****

            Const SW_SHOWNORMAL = 1

Диалоговое окно ввода данных

Sub InputDialog()

   Dim strInput As String

   ‘ Вызов стандартного диалогового окна ввода данных

   strInput = InputBox(«Введите данные», «Ввод данных»)

End Sub

Диалоговое окно настройки шрифта

Sub ShowFontDialog()

   ‘ Вызов стандартного окна настройки шрифта текущей ячейки

   Application.Dialogs(xlDialogActiveCellFont).Show

End Sub

Значения по умолчанию

Sub NewInputDialog()

   Dim strInput As String

   ‘ Вызов стандартного диалогового окна ввода со значением _

    по умолчанию

   strInput = InputBox(«Введите данные», «Ввод данных», _

    «Значение по умолчанию», 200, 200)

End Sub

ГЛАВА 7.ФОРМАТИРОВАНИЕ ТЕКСТА. ТАБЛИЦЫ. ГРАНИЦЫ И ЗАЛИВКА.

Вывод списка доступных шрифтов

Листинг 3.104. Список шрифтов

Sub ListOfFonts()

   Dim cbrcFonts As CommandBarControl

   Dim cbrBar As CommandBar

   Dim i As Integer

   ‘ Получение доступа к списку шрифтов (элемент управления в виде _

    раскрывающегося списка на панели инструментов «Форматирование»)

   Set cbrcFonts = Application.CommandBars(«Formatting»). _

    FindControl(ID:=1728)

   If cbrcFonts Is Nothing Then

      ‘ Панель «Форматирование» не открыта — откроем ее

      Set cbrBar = Application.CommandBars.Add

      Set cbrcFonts = cbrBar.Controls.Add(ID:=1728)

   End If

   ‘ Подготовка к выводу шрифтов (очистка ячеек)

   Range(«A:A»).ClearContents

   ‘ Вывод списка шрифтов в столбец «A» текущего листа

   For i = 0 To cbrcFonts.ListCount — 1

      Cells(i + 1, 1) = cbrcFonts.List(i + 1)

   Next i

   ‘ Закрытие панели инструментов «Форматирование», если мы были _

    вынуждены ее открывать

   On Error Resume Next

   cbrBar.Delete

End Sub

Выбор из текста всех чисел

Листинг 2.48. Функция ExtractNumeric

Function ExtractNumeric(iCell)

   ‘ Анализируется каждый символ входной строки iCell

   For iCount = 1 To Len(iCell)

      ‘ Проверка, является ли анализируемый символ числом

      If IsNumeric(Mid(iCell, iCount, 1)) = True Then

         ‘ Число добавляется в выходную строку

         ExtractNumeric = ExtractNumeric & Mid(iCell, iCount, 1)

      End If

   Next

End Function

Прописная буква только в начале текста

Листинг 2.49. Функция ПрописнНач

Function ПрописнНач(Текст)

   ‘ Пустой текст функция не обрабатывает

   If Текст = «» Then ПрописнНач = «<>»: Exit Function

   ‘ Выделение первого символа и перевод его в верхний регистр

   ПервыйСимвол = UCase(Left(Текст, 1))

   ‘ Выделение остальной части строки и перевод _

    ее в нижний регистр

   Обрубок = LCase(Mid(Текст, 2))

   ‘ Соединение частей строки и возврат значения

   ПрописнНач = ПервыйСимвол & Обрубок

End Function

Подсчет количества повторов искомого текста

Листинг 2.51. Функция CoincideCount

Function CoincideCount(Text, Search)

   ‘ Проверка правильности входных данных _

    (аргумента Search)

   If IsArray(Search) = True Then Exit Function

   If IsError(Search) = True Then Exit Function

   If IsEmpty(Search) = True Then Exit Function

   ‘ Просмотр заданного в параметре Text диапазона

   For Each iCell In Text

      ‘ Анализируются только ячейки, содержащие _

       корректные значения

      If Not IsError(iCell) Then

         ‘ iText — строка для просмотра (в нижнем регистре)

         iText = LCase(iCell)

         ‘ iSearch — искомое значение (в нижнем регистре)

         iSearch = LCase(Search)

         ‘ Длина искомой строки

         iLen = Len(Search)

         ‘ Первый поиск строки iSearch в строке iText _

          (этот и последующий поиски производятся без _

          учета регистра символов)

         iNumber = InStr(iText, iSearch)

         While iNumber > 0

            ‘ Поиск следующего вхождения строки

            iNumber = InStr(iNumber + iLen, iText, iSearch)

            ‘ Подсчет количества вхождений

            CoincideCount = CoincideCount + vbNull

         Wend

      End If

   Next

End Function

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

Листинг 2.76. Выделение элемента текста

Function dhGetTextItem(ByVal strTextIn As String, intItem As _

 Integer, strSeparator As String) As String

   Dim intStart As Integer ‘ Позиция начала текущего элемента

   Dim intEnd As Integer   ‘ Позиция конца текущего элемента

   Dim i As Integer        ‘ Номер текущего элемента

   ‘ Проверка корректности номера элемента

   If intItem < 1 Then Exit Function

   ‘ Убираются лишние пробелы, если разделитель — пробел

   If strSeparator = » » Then strTextIn = Application.Trim(strTextIn)

   ‘ Разделитель добавляется в конец строки

   If Right(strTextIn, Len(strTextIn)) <> strSeparator Then _

      strTextIn = strTextIn & strSeparator

   ‘ Поиск всех элементов в строке до нужного

   For i = 1 To intItem

      ‘ Начало элемента (перемещение вперед по строке)

      intStart = intEnd + 1

      ‘ Конец элемента

      intEnd = InStr(intStart, strTextIn, strSeparator)

      If (intEnd = 0) Then

         ‘ Дошли до конца строки, но элемент не нашли

         Exit Function

      End If

   Next i

   ‘ Выделение текста из входной строки

   dhGetTextItem = Mid(strTextIn, intStart, intEnd — intStart)

End Function

Отображение текста «задом наперед»

Листинг 2.71. Преобразование текста в обратном порядке

Function dhReverseText(strText As String) As String

   Dim i As Integer

   ‘ Переписываем символы из входной строки в выходную _

    в обратном порядке

   For i = Len(strText) To 1 Step -1

      dhReverseText = dhReverseText & Mid(strText, i, 1)

   Next i

End Function

Sub ReverseText()

   Dim strText As String

   ‘ Ввод строки посредством стандартного окна ввода

   strText = InputBox(«Введите текст:»)

   ‘ Реверсия строки и вывод результата

   MsgBox dhReverseText(strText), , strText

End Sub

Англоязычный текст — заглавными буквами

Листинг 2.70. Английский текст — в верхнем регистре

Function dhFormatEnglish(strText As String) As String

   Dim i As Integer

   Dim strCurChar As String * 1

   ‘ Анализируется каждый символ строки strText. Каждый символ _

    латинского алфавита преобразуется в верхний регистр

   For i = 1 To Len(strText)

      strCurChar = Mid(strText, i, 1)

      ‘ Код латинских строчных символов лежит в пределах _

       от 97 до 122

      If Asc(strCurChar) >= 97 And Asc(strCurChar) <= 122 Then

         ‘ Переводим символ в верхний регистр

         dhFormatEnglish = dhFormatEnglish & UCase(strCurChar)

      Else

         ‘ Просто добавляем символ в выходную строку

         dhFormatEnglish = dhFormatEnglish & strCurChar

      End If

   Next i

End Function

Запуск таблицы символов из Excel

Листинг 3.106. Вызов таблицы символов

Sub ShowSymbolTable()

   On Error Resume Next

   ‘ Запуск Charmap.exe — таблицы символов

   Shell «Charmap.exe», vbNormalFocus

   If Err <> 0 Then

      MsgBox «Невозможно запустить таблицу символов.», vbCritical

   End If

End Sub

Листинг 3.107. Таблица символов

‘ Декларация API-функций:

‘ для открытия процесса

Declare Function OpenProcess Lib «kernel32» _

 (ByVal dwDesiredAccess As ****, ByVal bInheritHandle As ****, _

 ByVal dwProcessId As ****) As ****

‘ для получения кода завершения процесса

Declare Function GetExitCodeProcess Lib «kernel32» _

 (ByVal hProcess As ****, lpExitCode As ****) As ****

‘ для закрытия процесса

Declare Function CloseHandle Lib «kernel32» _

 (hProcess) As ****

Sub ShowSymbolTable1()

   Dim lProcessID As ****

   Dim hProcess As ****

   Dim lExitCode As ****

   On Error Resume Next

   ‘ Запуск таблицы символов (Charman.exe). Функция возвращает _

    идентификатор созданного процесса

   lProcessID = Shell(«Charmap.exe», 1)

   If Err <> 0 Then

      MsgBox «Нельзя запустить Charman.exe», vbCritical, «Ошибка»

      Exit Sub

   End If

   ‘ Открытие процесса по идентификатору (lProcessID). Функция _

    возвращает дескриптор процесса (handle)

   hProcess = OpenProcess(&H400, False, lProcessID)

   ‘ Ждем, пока процесс завершится, для этого периодически _

    получаем код завершения процесса (пока Charman.exe исполняется, _

    функция GetExitCodeProcess возвращает &H103)

   Do

      GetExitCodeProcess hProcess, lExitCode

      DoEvents

   Loop While lExitCode = &H103

   ‘ Закрытие процесса

   CloseHandle (hProcess)

   ‘ Вывод на экран информационного сообщения

   MsgBox «Charmap.exe завершает свою работу»

End Sub

Листинг 3.64. Формат «два знака после запятой»

Sub ChangeNumberFormat()

   Selection.NumberFormat = «0.00»

End Sub

Листинг 3.65. Использование разделителя по разрядам

Sub ThreeNullSepatator()

   Selection.NumberFormat = «#,##»

End Sub

Листинг 3.66. Изменение формата

Sub ChangeNumerFormatEx()

   Selection.NumberFormat = «#,##0.00»

End Sub

Листинг 3.67. Помещение последнего символа над строкой

Sub LastCharUp()

   ‘ Изменение расположения последнего символа ячейки

   With ActiveCell.Characters(Start:=Len(Selection), Length:=1).Font

      .Supersсriрt = True

   End With

End Sub

Листинг 3.68. Нестандартная рамка

Sub ChangeSelGrid()

   ‘ Оформление границ выделения

   ‘ Левая граница

   With Selection.Borders(xlEdgeLeft)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Правая граница

   With Selection.Borders(xlEdgeRight)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Верхняя граница

   With Selection.Borders(xlEdgeTop)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Нижняя граница

   With Selection.Borders(xlEdgeBottom)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Изменение сетки внутри выделения

   ‘ Вертикальные линии сетки

   With Selection.Borders(xlInsideVertical)

      .LineStyle = xlContinuous

      .Weight = xlHairline

      .ColorIndex = xlAutomatic

   End With

   ‘ Горизонтальные линии сетки

   With Selection.Borders(xlInsideHorizontal)

      .LineStyle = xlContinuous

      .Weight = xlHairline

      .ColorIndex = xlAutomatic

   End With

End Sub

ГЛАВА 8 ИНФОРМАЦИЯ О ПОЛЬЗОВАТЕЛЕ, КОМПЬЮТЕРЕ, ПРИНТЕРЕ И Т.Д.

Получить имя пользователя

Логин юзера получить просто:

Dim UserName As String

UserName = CreateObject(«Wsсriрt.Network»).UserName

А как отслеживать — вариатнов много.

Я, например, просто не выполняю макрос, если логин не тот:

If ThisWorkbook.Sheets(«Rules»).Range(«Admin»).Find(CreateObject(«Wsсriрt.Network»).UserName, _

LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then Exit Sub

MsgBox «Имя пользователя : » & CreateObject(«Wsсriрt.Network»).UserNam

CreateObject(«Wsсriрt.Network»).UserName вместо Application.UserName

Вывод разрешения монитора

Листинг 3.73. Разрешение монитора

‘Объявление API-функции

Declare Function GetSystemMetrics Lib «user32» _

 (ByVal nIndex As ****) As ****

‘ Константы, которые передаются в функцию для определения _

 горизонтального и вертикального размеров изображения

Const SM_CXSCREEN = 0

Const SM_CYSCREEN = 1

Sub GetMonitorResolution()

   Dim lngHorzRes As ****

   Dim lngVertRes As ****

   ‘ Получение ширины и высоты изображения на мониторе

   lngHorzRes = GetSystemMetrics(SM_CXSCREEN)

   lngVertRes = GetSystemMetrics(SM_CYSCREEN)

   ‘ Отображение сообщения

   MsgBox «Текущее разрешение: » & lngHorzRes & «x» & lngVertRes

End Sub

Получение информации об используемом принтере

Информация о принтере

‘ Объявление API-функции

Declare Function GetProfileStringA Lib «kernel32» _

 (ByVal lpAppName As String, ByVal lpKeyName As String, _

 ByVal lpDefault As String, ByVal lpReturnedString As _

 String, ByVal nSize As ****) As ****

Sub Принтер()

   Dim strFullInfo As String * 255  ‘ Буфер для API-функции

   Dim strInfo As String            ‘ Строка с полной информацией

   Dim strPrinter As String         ‘ Название принтера

   Dim strDriver As String          ‘ Драйвер принтера

   Dim strPort As String            ‘ Порт принтера

   Dim strMessage As String

   Dim intPrinterEndPos As Integer

   Dim intDriverEndPos As Integer

   ‘ Заполнение буфера пробелами

   strFullInfo = Space(255)

   ‘ Получение полной информации о принтере

   Call GetProfileStringA(«Windows», «Device», «», strFullInfo, 254)

   ‘ Удаление лишних символов из конца возвращенной строки

   ‘ Строка strInfo имеет формат <имя_принтера>,<драйвер>,<порт>:

   strInfo = Trim(strFullInfo)

   ‘ Поиск запятых в строке (окончаний названий принтера и драйвера)

   intPrinterEndPos = Application.Find(«,», strInfo, 1)

   intDriverEndPos = Application.Find(«,», strInfo, intPrinterEndPos + 1)

   ‘ Определение названия принтера

   strPrinter = Left(strInfo, intPrinterEndPos — 1)

   ‘ Определение драйвера

   strDriver = Mid(strInfo, intPrinterEndPos + 1, intDriverEndPos _

    — intPrinterEndPos — 1)

   ‘ Определение порта (его название заканчивается символом «:»)

   strPort = Mid(strInfo, intDriverEndPos + 1, InStr(1, strInfo, «:») _

    — intDriverEndPos — 1)

   ‘ Формирование информационного сообщения

   strMessage = «Принтер:» & Chr(9) & strPrinter & Chr(13)

   strMessage = strMessage & «Драйвер:» & strDriver & Chr(13)

   strMessage = strMessage & «strPort:» & Chr(9) & strPort

   ‘ Вывод информационного сообщения

   MsgBox strMessage, vbInformation, «Сведения о принтере по умолчанию»

End Sub

Просмотр информации о дисках компьютера

Sub DrivesInfo()

   Dim objFileSysObject As Object  ‘ Объект для работы _

                                    с файловой системой

   Dim objDrive As Object          ‘ Анализируемый диск

   Dim intRow As Integer           ‘ Заполняемая строка листа

   ‘ Создание объекта для работы с файловой системой

   Set objFileSysObject = CreateObject(«sсriрting.FileSystemObject»)

   ‘ Очистка листа

   Cells.Clear

   ‘ Запись с первой строки

   intRow = 1

   ‘ Запись на лист информации о дисках компьютера

   On Error Resume Next

   For Each objDrive In objFileSysObject.Drives

      ‘ Буква диска

      Cells(intRow, 1) = objDrive.DriveLetter

      ‘ Готовность

      Cells(intRow, 2) = objDrive.IsReady

      ‘ Тип диска

      Select Case objDrive.DriveType

         Case 0

            Cells(intRow, 3) = «Неизвестно»

         Case 1

            Cells(intRow, 3) = «Съемный»

         Case 2

            Cells(intRow, 3) = «Жесткий»

         Case 3

            Cells(intRow, 3) = «Сетевой»

         Case 4

            Cells(intRow, 3) = «CD-ROM»

         Case 5

            Cells(intRow, 3) = «RAM»

      End Select

      ‘ Метка диска

      Cells(intRow, 4) = objDrive.VolumeName

      ‘ Общий размер

      Cells(intRow, 5) = objDrive.TotalSize

      ‘ Свободное место

      Cells(intRow, 6) = objDrive.AvailableSpace

      intRow = intRow + 1

   Next

End Sub

ГЛАВА 9. ДИАГРАММЫ

Построение диаграммы с помощью макроса

Листинг 5.1. Макрос построения диаграммы

Sub CreateChart()

   ‘ Создание и настройка диаграммы

   With Charts.Add

      ‘ Данные из первого листа

      .SetSourceData Source:=Worksheets(1).Range(«A1:E4»)

      ‘ Заголовок

      .HasTitle = True

      .ChartTitle.Text = «Выручка по магазинам»

      ‘ Активизируем диаграмму

      .Activate

   End With

End Sub

Листинг 5.2. Построение внедренной диаграммы

Sub CreateеmbеddedChart()

   ‘ Создание и настройка внедренной диаграммы

   With Worksheets(1).ChartObjects.Add(100, 60, 250, 200)

      ‘ Объемная диаграмма

      .Chart.ChartType = xl3DArea

      ‘ Источник данных

      .Chart.SetSourceData Source:=Worksheets(1).Range(«A1:E4»)

   End With

End Sub

Листинг 5.3. Создание диаграммы на основе выделенных данных

Sub CreateCharOnSelection()

   ‘ Создание диаграммы (с заданием положения на листе)

   With ActiveSheet.ChartObjects.Add( _

    Selection.Left + Selection.Width, _

    Selection.Top + Selection.Height, 300, 200).Chart

      ‘ Тип диаграммы

      .ChartType = xlColumnClustered

      ‘ Источник данных — выделение

      .SetSourceData Source:=Selection, PlotBy:=xlColumns

      ‘ Без легенды

      .HasLegend = False

      ‘ Без заголовка

      .HasTitle = True

      .ChartTitle.Characters.Text = «Выручка за период»

      ‘ Выделение диаграммы

      .Parent.Select

   End With

End Sub

Сохранение диаграммы в отдельном файле

Листинг 5.4. Сохранение диаграммы

Sub SaveChart()

   ‘ Сохранение выделенной диаграммы в файл

   If ActiveChart Is Nothing Then

      ‘ Нет выделенных диаграмм

      MsgBox «Выделите диаграмму»

   Else

      ‘ Сохранение…

      ActiveChart.Export ActiveWorkbook.path & «Диаграмма.gif», «GIF»

   End If

End Sub

Листинг 5.5. Сохранение диаграммы под указанным именем

Sub InteractiveSaveChart()

   Dim strFileName As String  ‘ Имя файла для сохранения

   ‘ Проверка, выделена ли диаграмма

   If ActiveChart Is Nothing Then

      ‘ Нет выделенных диаграмм

      MsgBox «Выделите диаграмму»

   Else

      ‘ Выбор файла для сохранения

      strFileName = Application.GetSaveAsFilename( _

       ActiveChart.Name & «.gif», «Файлы GIF (*.gif), *.gif», 1, _

       «Сохранить диаграмму в формате GIF»)

      ‘ Проверка, выбран ли файл

      If strFileName <> «» Then

         ‘ Сохранение выделенной диаграммы в файл

         ActiveChart.Export strFileName, «GIF»

      End If

   End If

End Sub

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

Листинг 5.6. Быстрое построение и удаление диаграммы

Sub CreateChart()

   ‘ Создание диаграммы

   Charts.Add

   ‘ Параметры диаграммы

   ‘ Тип диаграммы

   ActiveChart.ChartType = xlLineMarkers

   ‘ Заголовок

   ActiveChart.SetSourceData Range(«B1:E2»), xlRows

   ActiveChart.Location xlLocationAsObject, Name

   ‘ Остальные параметры

   With ActiveChart

      ‘ Заголовок

      .HasTitle = True

      .ChartTitle.Characters.Text = Name

      ‘ Заголовок оси категорий

      .Axes(xlCategory, xlPrimary).HasTitle = True

      .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text _

       = Sheets(Name).Range(«A1»).Value

      ‘ Заголовок оси значений

      .Axes(xlValue, xlPrimary).HasTitle = True

      .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text _

       = Sheets(Name).Range(«A2»).Value

      ‘ Отображение легенды

      .HasLegend = False

      .HasDataTable = True

      .DataTable.ShowLegendKey = True

      ‘ Настройка отображения сетки

      With .Axes(xlCategory)

         .HasMajorGridlines = True

         .HasMinorGridlines = False

      End With

      With .Axes(xlValue)

         .HasMajorGridlines = True

         .HasMinorGridlines = False

      End With

   End With

End Sub

Sub DeleteChart()

   ‘ Удаление диаграммы

   ActiveSheet.ChartObjects.Delete

End Sub

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

Листинг 5.7. Внедренные диаграммы

Sub ShowSheetCharts()

   Dim strMessage As String

   Dim i As Integer

   ‘ Формирование списка диаграмм

   For i = 1 To ActiveSheet.ChartObjects.Count

      strMessage = strMessage & ActiveSheet.ChartObjects(i).Name _

       & vbNewLine

   Next i

   ‘ Отображение списка

   MsgBox strMessage

End Sub

Листинг 5.8. Перечень рабочих листов, содержащих обычные диаграммы

Sub ShowBookCharts()

   Dim crt As chart

   Dim strMessage As String

   ‘ Формирование списка диаграмм

   For Each crt In ActiveWorkbook.Charts

      strMessage = strMessage & crt.Name & vbNewLine

   Next

   ‘ Отображение списка

   MsgBox strMessage

End Sub

Применение случайной цветовой палитры

Листинг 5.9. Случайная цветовая палитра

Sub RandomChartColors()

   Dim intGradientStyle As Integer, intGradientVariant As Integer

   Dim i As Integer

   ‘ Проверка, выделена ли диаграмма

   If ActiveChart Is Nothing Then Exit Sub

   ‘ Изменение оформления всех категорий

   For i = 1 To ActiveChart.SeriesCollection.Count

      With ActiveChart.SeriesCollection(i)

         ‘ Вид градиентной заливки (случайный)

         intGradientStyle = Int(Rnd * 7) + 1

         If intGradientStyle = 6 Then intGradientStyle = 1

         If intGradientStyle = 7 Then

            intGradientVariant = Int(Rnd * 2) + 1

         Else

            intGradientVariant = Int(Rnd * 4) + 1

         End If

         ‘ Применение градиента

         .Fill.TwoColorGradient Style:=intGradientStyle, _

          Variant:=intGradientVariant

         ‘ Установка случайных цветов фона и обводки (используются _

          для градиента)

         .Fill.ForeColor.SchemeColor = Int(Rnd * 57) + 1

         .Fill.BackColor.SchemeColor = Int(Rnd * 57) + 1

      End With

   Next i

End Sub

Эффект прозрачности диаграммы

Листинг 5.10. Эффект прозрачности диаграммы

Sub TransparentChart()

   Dim shpShape As Shape

   Dim dblColor As Double

   Dim srSerie As Series

   Dim intBorderLineStyle As Integer

   Dim intBorderColorIndex As Integer

   Dim intBorderWeight As Integer

   ‘ Проверка, есть ли выделенная диаграмма

   If ActiveChart Is Nothing Then Exit Sub

   ‘ Изменение отображения каждой категории

   For Each srSerie In ActiveChart.SeriesCollection

      If (srSerie.ChartType = xlColumnClustered Or _

       srSerie.ChartType = xlColumnStacked Or _

       srSerie.ChartType = xlColumnStacked100 Or _

       srSerie.ChartType = xlBarClustered Or _

       srSerie.ChartType = xlBarStacked Or _

       srSerie.ChartType = xlBarStacked100) Then

         ‘ Сохранение прежнего цвета категории

         dblColor = srSerie.Interior.Color

         ‘ Сохранение стиля линий

         intBorderLineStyle = srSerie.Border.LineStyle

         ‘ Цвет границы

         intBorderColorIndex = srSerie.Border.ColorIndex

         ‘ Толщина линий границы

         intBorderWeight = srSerie.Border.Weight

         ‘ Создание автофигуры

         Set shpShape = ActiveSheet.shapes.AddShape _

          (msoShapeRectangle, 1, 1, 100, 100)

         With shpShape

            ‘ Закрашиваем нужным цветом

            .Fill.ForeColor.RGB = dblColor

            ‘ Делаем прозрачной

            .Fill.Transparency = 0.4

            ‘ Убираем линии

            .Line.Visible = msoFalse

         End With

         ‘ Копируем автофигуру в буфер обмена

         shpShape.CopyPicture Appearance:=xlScreen, _

          Format:=xlPicture

         ‘ Вставляем автофигуру в изображения столбцов _

          категории и настраиваем

         With srSerie

            ‘ Собственно вставка

            .Paste

            ‘ Возвращаем на место толщину линий

            .Border.Weight = intBorderWeight

            ‘ Стиль линий

            .Border.LineStyle = intBorderLineStyle

            ‘ Цвет границы

            .Border.ColorIndex = intBorderColorIndex

         End With

         ‘ Автофигура больше не нужна

         shpShape.Delete

      End If

   Next srSerie

End Sub

Построение диаграммы на основе данных нескольких рабочих листов

Листинг 5.11. Одновременное создание нескольких диаграмм

Sub ManyCharts()

   Dim intTop As ****, intLeft As ****

   Dim intHeight As ****, intWidth As ****

   Dim sheet As Worksheet

   Dim lngFirstRow As ****      ‘ Первая строка с данными

   Dim intSerie As Integer      ‘ Текущая категория диаграммы

   Dim strErrorSheets As String ‘ Список листов, для которых _

                                 не удалось построить диаграммы

   intTop = 1       ‘ Верхняя точка первой диаграммы

   intLeft = 1      ‘ Левая точка каждой диаграммы

   intHeight = 180  ‘ Высота каждой диаграммы

   intWidth = 300   ‘ Ширина каждой диаграммы

   ‘ Постоение диаграммы для каждого листа, кроме текущего

   For Each sheet In ActiveWorkbook.Worksheets

      If sheet.Name <> ActiveSheet.Name Then

         ‘ Первый заполненный ряд

         lngFirstRow = 3

         ‘ Первая категория

         intSerie = 1

         On Error GoTo DiagrammError

         ‘ Добавление и настройка диаграммы

         With ActiveSheet.ChartObjects.Add _

          (intLeft, intTop, intWidth, intHeight).Chart

            Do Until IsEmpty(sheet.Cells(lngFirstRow + intSerie, 1))

               ‘ Создание ряда

               .SeriesCollection.NewSeries

               ‘ Значения для ряда

               .SeriesCollection(intSerie).Values = _

                sheet.Range(sheet.Cells(lngFirstRow + intSerie, 2), _

                sheet.Cells(lngFirstRow + intSerie, 4))

               ‘ Диапазон данных для подписей

               .SeriesCollection(intSerie).XValues = _

                sheet.Range(«B3:D3»)

               ‘ Название ряда (берется из столбца «A» таблицы с данными)

               .SeriesCollection(intSerie).Name = sheet.Cells( _

                lngFirstRow + intSerie, 1)

               intSerie = intSerie + 1

            Loop

            ‘ Настройка внешнего вида диаграммы

            .ChartType = xl3DColumnClustered

            .ChartGroups(1).GapWidth = 20

            .PlotArea.Interior.ColorIndex = xlNone

            .ChartArea.Font.Size = 9

            ‘ Диаграмма с легендой

            .HasLegend = True

            ‘ Заголовок

            .HasTitle = True

            .ChartTitle.Characters.Text = sheet.Range(«A1»)

            ‘ Задание диапазона значений на осях

            .Axes(xlValue).MinimumScale = 0

            .Axes(xlValue).MaximumScale = 120000

            ‘ Стиль линий сетки (прерывистый)

            .Axes(xlValue).MajorGridlines.Border. _

             LineStyle = xlDot

         End With

         On Error GoTo 0

         ‘ Сдвиг верхней точки следующей диаграммы на высоту _

          текущей диаграммы

         intTop = intTop + intHeight

AfterError:

      End If

   Next sheet

   If strErrorSheets <> «» Then

      ‘ Отобразим список листов, для которых не построили диаграммы

      MsgBox «Не удалось построить диаграммы для листов:» & Chr(13) _

       & strErrorSheets, vbExclamation

   End If

   Exit Sub

DiagrammError:

   ‘ Добавление в список имени листа, для которого не смогли _

    построить диаграмму (ошибка в данных для диаграммы)

   strErrorSheets = strErrorSheets & sheet.Name & Chr(13)

   ‘ Удаление пустой диаграммы на текущем листе

   ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete

   ‘ Продолжаем работу с другими листами

   Resume AfterError

End Sub

Создание подписей к данным диаграммы

Листинг 5.12. Подписи к данным диаграммы

Sub ShowLabels()

   Dim rgLabels As Range    ‘ Диапазон с подписями

   Dim chrChart As Chart    ‘ Диаграмма

   Dim intPoint As Integer  ‘ Точка, для которой добавляется подпись

   ‘ Определение диаграммы

   Set chrChart = ActiveSheet.ChartObjects(1).Chart

   ‘ Запрос на ввод диапазона с исходными данными

   On Error Resume Next

   Set rgLabels = Application.InputBox _

    (prompt:=»Укажите диапазон с подписями», Type:=8)

   If rgLabels Is Nothing Then Exit Sub

   On Error GoTo 0

   ‘ Добавление подписей

   chrChart.SeriesCollection(1).ApplyDataLabels _

    Type:=xlDataLabelsShowValue, _

    AutoText:=True, _

    LegendKey:=False

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

   For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

      chrChart.SeriesCollection(1). _

       Points(intPoint).DataLabel.Text = rgLabels(intPoint)

   Next intPoint

End Sub

Sub DeleteLabels()

   ‘ Удаление подписей диаграммы

   ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

    HasDataLabels = False

End Sub

ГЛАВА 10. РАЗНЫЕ ПРОГРАММЫ.

Программа для составления кроссвордов

Листинг 6.1. Программа для составления кроссворда

Const dhcMinCol = 1   ‘ Номер первого столбца кроссворда

Const dhcMaxCol = 35  ‘ Номер последнего столбца кроссворда

Const dhcMinRow = 1   ‘ Номер первой строки кроссворда

Const dhcMaxRow = 35  ‘ Номер последней строки кроссворда

Sub Clear()

   ‘ Выделение и очистка всех используемых для кроссворда ячеек

   Range(Cells(dhcMinRow, dhcMinCol), _

    Cells(dhcMaxRow, dhcMaxCol)).Select

   Selection.Clear

   ‘ Удаление сетки всего кроссворда

   ClearGrid

   Range(«A1»).Select

End Sub

Sub ClearGrid()

   ‘ Удаление сетки кроссворда (в выделенных ячейках)…

   ‘ Возврат прежнего цвета ячеек

   Selection.Interior.ColorIndex = xlNone

   ‘ Задание начертания границ ячеек по умолчанию

   Selection.Borders(xlDiagonalDown).LineStyle = xlNone

   Selection.Borders(xlDiagonalUp).LineStyle = xlNone

   Selection.Borders(xlEdgeLeft).LineStyle = xlNone

   Selection.Borders(xlEdgeTop).LineStyle = xlNone

   Selection.Borders(xlEdgeBottom).LineStyle = xlNone

   Selection.Borders(xlEdgeRight).LineStyle = xlNone

   Selection.Borders(xlInsideVertical).LineStyle = xlNone

   Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub DrowCrosswordGrid()

   ‘ Процедура начертания сетки кроссворда

   ‘ Задание цвета всех ячеек кроссворда

   Selection.Interior.ColorIndex = 35

   ‘ Линии по диагонали не нужны

   Selection.Borders(xlDiagonalDown).LineStyle = xlNone

   Selection.Borders(xlDiagonalUp).LineStyle = xlNone

   ‘ Задание начертания границ всех диапазонов, входящих _

    в выделение, а также границ между соседними ячейками _

    всех диапазонов

   On Error Resume Next

   ‘ Левые границы

   With Selection.Borders(xlEdgeLeft)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Правые границы

   With Selection.Borders(xlEdgeRight)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Верхние границы

   With Selection.Borders(xlEdgeTop)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Нижние границы

   With Selection.Borders(xlEdgeBottom)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Вертикальные границы между ячейками

   With Selection.Borders(xlInsideVertical)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

   ‘ Горизонтальные границы между ячейками

   With Selection.Borders(xlInsideHorizontal)

      .LineStyle = xlContinuous

      .Weight = xlThin

      .ColorIndex = xlAutomatic

   End With

End Sub

Sub DisplayGrid()

   ‘ Включение сетки на листе

   ActiveWindow.DisplayGridlines = True

End Sub

Sub HideGrid()

   ‘ Выключение сетки на листе

   ActiveWindow.DisplayGridlines = False

End Sub

Sub AutoNumber()

   ‘ Нумерация клеток, являющихся началом слов

   Dim intRow As Integer    ‘ Текущая строка

   Dim intCol As Integer    ‘ Текущий ряд

   Dim cell As Range        ‘ Текущая ячейка (с координатами _

                             (intRow, intCol))

   Dim fTop As Boolean      ‘ = True, если cell имеет соседей сверху

   Dim fBottom As Boolean   ‘ = True, если cell имеет соседей снизу

   Dim fLeft As Boolean     ‘ = True, если cell имеет соседей слева

   Dim fRight As Boolean    ‘ = True, если cell имеет соседей справа

   Dim intDigit As Integer  ‘ Текущий номер слова в кроссворде

   intDigit = 1             ‘ Нумерация слов с 1

   ‘ Проходим по всем клеткам диапазона, используемого _

    для кроссворда, сверху вниз слева направо и анализируем _

    каждую угловую и крайнюю (левую и верхнюю) ячейки

   For intRow = dhcMinRow To dhcMaxRow

      For intCol = dhcMinCol To dhcMaxCol

         ‘ Текущая ячейка

         Set cell = Cells(intRow, intCol)

         ‘ Проверка, входит ли ячейка в кроссворд (по ее цвету)

         If cell.Interior.ColorIndex = 35 Then

            fLeft = False

            fRight = False

            fTop = False

            fBottom = False

            On Error Resume Next

            ‘ Определение наличия соседей у ячейки…

            ‘ сверху

            fTop = cell.Offset(-1, 0).Interior.ColorIndex = 35

            ‘ снизу

            fBottom = cell.Offset(1, 0).Interior.ColorIndex = 35

            ‘ слева

            fLeft = cell.Offset(0, -1).Interior.ColorIndex = 35

            ‘ справа

            fRight = cell.Offset(0, 1).Interior.ColorIndex = 35

            On Error GoTo 0

            ‘ Анализ положения ячейки

            If (Not fTop And Not fLeft) Or _

             (Not fBottom And Not fLeft And fRight) Or _

             (Not fLeft And fRight) Or _

             (Not fTop And fBottom) Then

               ‘ Ячейка подходит для начала слова

               SetDigit intDigit, cell

               intDigit = intDigit + 1

            End If

         End If

      Next intCol

   Next intRow

End Sub

Sub SetDigit(intDigit As Integer, cell As Range)

   ‘ Вставка цифры intDigit в ячейку, заданную параметром cell

   cell.Value = intDigit

   ‘ Изменение настроек шрифта так, чтобы было похоже _

    на настоящий кроссворд

   ‘ Маленький размер шрифта

   cell.Font.Size = 6

   ‘ Выравнивание текста по левому верхнему углу ячейки

   cell.HorizontalAlignment = xlLeft

   cell.VerticalAlignment = xlTop

End Sub

Sub ToPrint()

   ‘ Удаление цветовой подсветки кроссворда

   Cells.Interior.ColorIndex = xlNone

End Sub

Sub ToNumber()

   ‘ Закрытие первой формы и переход ко второй

   UserForm1.Hide

   UserForm2.Show

End Sub

Создать обложку DVD

Sub Обложка_DVD()

On Error Resume Next

Sheets(«Обложка»).Select

If Err > 0 Then GoTo 10 Else MsgBox («Такой лист уже присутствует в книге…»): Exit Sub

10:

Sheets.Add.Name = «Обложка» ‘ создаем новый лист в текущей книге с именем «Обложка»

Sheets(«Обложка»).Range(«A1»).Select ‘ становимся в ячейку А1

Application.Dialogs(xlDialoginsеrtPicture).Show ‘вызываем диологовое окно «Вставка рисунка из файла»

Selection.ShapeRange.LockAspectRatio = msoFalse ‘

‘ Selection.ShapeRange.Height = 530.25 ‘ подгоняем размеры под размеры коробки

‘ Selection.ShapeRange.Width = 726# ‘

Selection.ShapeRange.Height = 530.2 ‘ подгоняем размеры под размеры коробки

Selection.ShapeRange.Width = 724# ‘

Selection.ShapeRange.Rotation = 0# ‘

Selection.Locked = False ‘

With ActiveSheet.PageSetup ‘ разносим поля листа на максимальные расстояния

.LeftMargin = Application.InchesToPoints(0.17)

.RightMargin = Application.InchesToPoints(0.17)

.TopMargin = Application.InchesToPoints(0.27)

.BottomMargin = Application.InchesToPoints(0.27)

.HeaderMargin = Application.InchesToPoints(0.17)

.FooterMargin = Application.InchesToPoints(0.17)

.Zoom = 100

.FitToPagesWide = 1

.FitToPagesTall = 1

.Orientation = xlLandscape ‘ придаем листу горизантальное положение (АЛЬБОМНЫЙ)

End With

If MsgBox(«Печать текущего изображения», vbYesNo, «Вывод на печать») = vbYes Then Sheets(«Обложка»).PrintOut Copies:=1, Collate:=True

Application.DisplayAlerts = False ‘ Выключили системные сообщения…

If MsgBox(«Удалить лист ОБЛОЖКА», vbYesNo, «Удаление листа…») = vbYes Then Sheets(«Обложка»).Delete Else Application.CommandBars(«Picture»).Visible = True

Application.DisplayAlerts = True ‘Включили системные сообщения…

End Sub

Игра «Минное поле»

Листинг 6.2. Код в модуле рабочего листа

Sub Worksheet_Selectiоnchange(ByVal Target As Range)

   Dim intCol As Integer, intRow As Integer

   Dim intMinesAround As Integer

   Dim fInGameField As Boolean

   ‘ Определим, попадает ли в игровое поле выделенная ячейка

   fInGameField = (Target.Row >= 2) And (Target.Row <= 7) _

    And (Target.Column >= 2) And (Target.Column <= 7)

   ‘ Обрабатываем выделение ячейки

   If Target.Value = «*» And fInGameField Then

      ‘ Пользователь выделил ячейку с миной — покажем мину

      Target.Font.Color = RGB(0, 0, 0)

      Target.Interior.Color = RGB(255, 0, 0)

      ‘ Пользователь проиграл!

      EndGame

   ElseIf fInGameField Then

      ‘ Пользователь выделил пустую ячейку. Оформим эту ячейку

      Target.Interior.Color = RGB(0, 0, 255)

      Target.Font.Color = RGB(0, 255, 0)

      Target.Font.Size = 16

      ‘ Подсчитаем количество мин рядом с ячейкой (вокруг ячейки)

      For intCol = Target.Column — 1 To Target.Column + 1

         For intRow = Target.Row — 1 To Target.Row + 1

            If Target.Worksheet.Cells(intRow, intCol).Value = «*» _

             Then

               ‘ Нашли очередную мину

               intMinesAround = intMinesAround + 1

            End If

         Next

      Next

      ‘ Отображение количества мин

      Target.Value = intMinesAround

   End If

End Sub

Листинг 6.3. Код в стандартном модуле

Sub NewGame()

   ‘ Начало новой игры

   ‘ Подготовим поле для игры

   InitGame

   Dim intRow As Integer, intCol As Integer

   Dim intMinesCount As Integer    ‘ Количество мин

   ‘ Расставляем мины (то есть в случайные ячейки помещаем _

    значения «*» и делаем цвет шрифта таким же, как цвет _

    фона этих ячеек)

   For intMinesCount = 1 To 10

      ‘ Строка для мины (от 2 до 7)

      intRow = Int((6 * Rnd) + 1) + 1

      ‘ Столбец для мины (от 2 до 7)

      intCol = Int((6 * Rnd) + 1) + 1

      ‘ Ставим мину, если ячейка пустая

      If Cells(intRow, intCol) <> «*» Then

         Cells(intRow, intCol).Font.Color = _

          Cells(intRow, intCol).Interior.Color

         Cells(intRow, intCol).Value = «*»

      Else

         ‘ В данной ячейке мина есть — продолжим поиск ячеек

         intMinesCount = intMinesCount — 1

      End If

   Next

   ‘ Вывод информации о количестве мин в строку состояния

   Application.StatusBar = «Количество мин » & intMinesCount

End Sub

Sub InitGame()

   ‘ Раскраска (оформление) листа перед началом игры

   Dim intRow As Integer, intCol As Integer

   ‘ Цвет фона всех ячеек

   Cells.Interior.Color = RGB(0, 200, 75)

   ‘ Цвет шрифта всех ячеек

   Cells.Font.Color = RGB(0, 0, 0)

   ‘ Размер шрифта

   Cells.Font.Size = 18

   ‘ Все надписи — по центру

   Cells.HorizontalAlignment = xlCenter

   ‘ Всем ячейкам игрового поля назначим особый цвет

   For intRow = 2 To 7

      For intCol = 2 To 7

         Cells(intRow, intCol).Interior.Color = RGB(200, 200, 200)

         Cells(intRow, intCol).Value = «»

      Next

   Next

End Sub

Sub EndGame()

   ‘ Завершение игры (поражение)

   Dim intRow As Integer, intCol As Integer

   ‘ Покажем все мины. Для этого сделаем цвет шрифта всех ячеек _

    черным (ведь во всех ячейках с минами «*» цвет шрифта и цвет _

    заливки одинаковы)

   For intRow = 2 To 7

      For intCol = 2 To 7

         If Cells(intRow, intCol).Value = «*» Then

            Cells(intRow, intCol).Font.Color = RGB(0, 0, 0)

         End If

      Next

   Next

   MsgBox «Проигрыш»

End Sub

Игра «Угадай животное»

Листинг 6.4. Игра «Угадай животное»

Sub StartGame()

   Dim intLastRow As Integer    ‘ Номер строки для вставки записей

   Dim intRow As Integer        ‘ Номер текущей строки

   Dim intYesRow As Integer     ‘ Номер строки, из которой брать _

                                 данные при утвердительном ответе

   Dim intNoRow As Integer      ‘ Номер строки, из которой брать _

                                 данные при отрицательном ответе

   Dim strText As String        ‘ Строка с вопросом или названием _

                                 животного

   Dim strNewName As String     ‘ Строка с названием нового животного

   Dim strNewQuestion As String ‘ Строка с новым вопросом

   Dim intRes As Integer

   ‘ Начало игры

   MsgBox «Начнем игру. Задумайте животное.», vbOKOnly, _

    «Задумайте животное»

   ‘ Определение номера ряда для вставки записей. _

    intLastRow-1 — номер последнего ряда, содержащего данные

   intLastRow = Worksheets(«Data»).Range(«D1»).Value + 1

   ‘ Данные в таблице идут с первого ряда

   intRow = 1

   Do While intRow < intLastRow

      ‘ Текст вопроса или название животного из столбца «A»

      strText = Worksheets(«Data»).Cells(intRow, 1).Value

      ‘ Номер ряда, из которого брать данные при утвердительном _

       ответе, берем из столбца «B»

      intYesRow = Worksheets(«Data»).Cells(intRow, 2).Value

      ‘ Номер ряда, из которого брать данные при отрицательном _

       ответе, берем из столбца «C»

      intNoRow = Worksheets(«Data»).Cells(intRow, 3).Value

      If intYesRow > 0 Then

         ‘ В строке strText содержится вопрос. Зададим его

         intRes = MsgBox(strText, vbYesNo, «Вопрос»)

         If intRes = vbYes Then

            ‘ Переходим по утвердительному ответу

            intRow = intYesRow

         Else

            ‘ Переходим по отрицательному ответу

            intRow = intNoRow

         End If

      Else

         ‘ Альтернативы закончились. В строке strText — название _

          животного. Спросим, его ли загадали

         intRes = MsgBox(«Это » & strText & «?», vbYesNo, «Вопрос»)

         If intRes = vbYes Then

            ‘ Животное угадано

            MsgBox «Угадано! Спасибо за игру!», vbOKOnly, _

             «Игра завершена»

            Exit Do

         Else

            ‘ Животное не угадали, но данные уже занкончились. _

             Нужно пополнить наши данные, чтобы отличать животное _

             с названием strText от загаданного

            ‘ Ввод названия нового животного

            strNewName = InputBox(«Сдаюсь. Кто это?», _

             «Напечатайте название животного»)

            If strNewName <> «» Then

               ‘ Ввод вопроса, по которому отличать животных

               strNewQuestion = InputBox(«Задайте вопрос, по » & _

                «которому можно отличить ‘» & strNewName & _

                «‘ от ‘» & strText & «‘», «Напечатайте вопрос»)

               If strNewQuestion <> «» Then

                  ‘ Определение, какое из животных соответствует _

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

                  intRes = MsgBox(«Правильный ответ на ваш » & _

                   «вопрос — » & strNewName & «‘», vbYesNo, _

                   «Какой ответ на вопрос?»)

                  ‘ Добавление в таблицу названия нового животного

                  Worksheets(«Data»).Cells(intLastRow, 1). _

                   Value = strNewName

                  ‘ Перемещения названия животного, которое было _

                   ранее, в конец таблицы

                  Worksheets(«Data»).Cells(intLastRow + 1, 1). _

                   Value = strText

                  ‘ Замена названия этого животного вопросом

                  Worksheets(«Data»).Cells(intRow, 1). _

                   Value = strNewQuestion

                  ‘ Корректировка номеров строк для перехода _

                   в зависимости от того, какое животное является _

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

                  If intRes = vbYes Then

                     ‘ Новое животное — правильный ответ

                     Worksheets(«Data»).Cells(intRow, 2). _

                      Value = intLastRow

                     Worksheets(«Data»).Cells(intRow, 3). _

                      Value = intLastRow + 1

                  Else

                     ‘ Бывшее ранее животное — правильный ответ

                     Worksheets(«Data»).Cells(intRow, 2). _

                      Value = intLastRow + 1

                     Worksheets(«Data»).Cells(intRow, 3). _

                      Value = intLastRow

                  End If

                  ‘ Сохраним номер строки для добавления записей

                  Worksheets(«Data»).Range(«D1»).Value = _

                   intLastRow + 2

               End If

            End If

            ‘ Игра завершена. Таблица дополнена

            MsgBox «Спасибо за игру!», vbOKOnly, «Игра завершена»

            Exit Do

         End If

      End If

   Loop

End Sub

Расчет на основании ячеек определенного цвета

Листинг 6.5. Код в стандартном модуле

Const dhcSum As Integer = 0

Const dhcAvg As Integer = 1

Const dhcMax As Integer = 2

Const dhcMin As Integer = 3

Const dhcCount As Integer = 4

Const dhcSumPlus As Integer = 5

Const dhcSumMinus As Integer = 6

Const dhcCountFull As Integer = 7

Const dhcCountNotNull As Integer = 8

Const dhcCountPlus As Integer = 9

Const dhcCountMinus As Integer = 10

Sub CalcColors()

   ‘ Отображение формы

   Load frmColorCalc

   frmColorCalc.Show

End Sub

Public Function ColorCalc(strRange As String, _

   lngColor As ****, fBackBolor As Boolean, _

   intMode As Integer, Optional fAbsence As Boolean) As Double

   ‘ Операции над ячейками с установленным цветом шрифта _

    или заливки

   Dim rgData As Range     ‘ Диапазон ячеек для расчетов

   Dim i As Integer

   Dim Values() As Variant ‘ Массив со значениями для расчета

   Dim intCount As Integer ‘ Количество значений в массиве

   Dim cell As Range

   Dim varOut As Variant   ‘ В этой переменной хранятся _

                            результаты промежуточных подсчетов _

                            и окончательный результат

   Set rgData = Range(strRange)

   ReDim Values(1 To rgData.Count)

   ‘ Просматриваются все ячейки входного диапазона. Значения тех из них, _

    цвет которых удовлетворяет условию, записываются в массив Values

   For Each cell In rgData.Cells

      ‘ Если нужно суммировать по заливке:

      If fBackBolor = True Then

         ‘ Включение ячейки в сумму в зависимости от цвета _

          заливки и фильтра

         If fAbsence Then

            ‘ Если ячейка имеет заданный цвет, то она не включается _

             в вычисления

            If cell.Interior.Color <> lngColor Then

               intCount = intCount + 1

               Values(intCount) = cell.Value

            End If

         Else

            ‘ Если ячейка имеет заданный цвет, то она включается _

             в вычисления

            If cell.Interior.Color = lngColor Then

               intCount = intCount + 1

               Values(intCount) = cell.Value

            End If

         End If

         ‘ В противном случае — суммируется по шрифту

      Else

         ‘ Включение ячейки в сумму в зависимости _

          от ее цвета и фильтра

         If fAbsence Then

            ‘ Если ячейка имеет заданный цвет, то она не включается _

             в вычисления

            If cell.Font.Color <> lngColor Then

               intCount = intCount + 1

               Values(intCount) = cell.Value

            End If

         Else

            ‘ Если ячейка имеет заданный цвет, то она включается _

             в вычисления

            If cell.Font.Color = lngColor Then

               intCount = intCount + 1

               Values(intCount) = cell.Value

            End If

         End If

      End If

   Next cell

   ‘ Выполнение над собранными значениями операции, заданной в intMode

   For i = 1 To intCount

      Select Case intMode

         Case dhcSum, dhcAvg

            ‘ Подсчет суммы значений

            varOut = varOut + Values(i)

         Case dhcSumPlus

            ‘ Подсчет суммы положительных значений

            If Values(i) > 0 Then varOut = varOut + Values(i)

         Case dhcSumMinus

            ‘ Посчет суммы отрицательных значений

            If Values(i) < 0 Then varOut = varOut + Values(i)

         Case dhcMax

            ‘ Нахождение максимального значения

            If Values(i) > varOut Then varOut = Values(i)

         Case dhcMin

            ‘ Нахождение минимального значения

            If i = LBound(Values) Then varOut = Values(i)

            If Values(i) < varOut Then varOut = Values(i)

         Case dhcCount

            ‘ Подсчет количества значений

            varOut = varOut + 1

         Case dhcCountFull

            ‘ Подсчет количества заполненных ячеек

            If Not IsEmpty(Values(i)) Then varOut = varOut + 1

         Case dhcCountNotNull

            ‘ Подсчет количества пустых ячеек

            If Not IsEmpty(Values(i)) And Values(i) <> 0 Then _

             varOut = varOut + 1

         Case dhcCountPlus

            ‘ Подсчет количества положительных значений

            If Values(i) > 0 Then varOut = varOut + 1

         Case dhcCountMinus

            ‘ Подсчет количества отрицательных значений

            If Values(i) < 0 Then varOut = varOut + 1

      End Select

   Next i

   ‘ Окончательные операции для некоторых видов расчета

   If intMode = dhcAvg Then

      ‘ Вычисление среднего значения

      ColorCalc = varOut / intCount

   Else

      ColorCalc = varOut

   End If

End Function

Листинг 6.6. Код в модуле формы

Dim lngCurColor As **** ‘ Выбранный цвет, по которому _

                         идентифицировать (отбирать) ячейки

Dim intMode As Integer  ‘ Номер типа вычисления в списке

Sub cmbApplyColor_Click()

   If cboOtherColor.Value >= 0 Then

      ‘ Вычисление с использованием выбранного в списке цвета

      lngCurColor = cboOtherColor.Value

      SetColorSum

   End If

End Sub

Sub cmbColor1_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor1.BackColor

   SetColorSum

End Sub

Sub cmbColor2_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor2.BackColor

   SetColorSum

End Sub

Sub cmbColor3_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor3.BackColor

   SetColorSum

End Sub

Sub cmbColor4_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor4.BackColor

   SetColorSum

End Sub

Sub cmbColor5_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor5.BackColor

   SetColorSum

End Sub

Sub cmbColor6_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor6.BackColor

   SetColorSum

End Sub

Sub cmbColor7_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor7.BackColor

   SetColorSum

End Sub

Sub cmbColor8_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor8.BackColor

   SetColorSum

End Sub

Sub cmbColor9_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor9.BackColor

   SetColorSum

End Sub

Sub cmbColor10_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor10.BackColor

   SetColorSum

End Sub

Sub cmbColor11_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor11.BackColor

   SetColorSum

End Sub

Sub cmbColor12_Click()

   ‘ Вычисление с использованием цвета нажатой кнопки

   lngCurColor = cmbColor12.BackColor

   SetColorSum

End Sub

Sub SetColorSum()

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

   Dim strFormula As String

   ‘ Проверка правильности введенных диапазонов и номеров ячеек

   If txtResCell.Value = «» Then

      MsgBox «Введите адрес ячейки вставки функции», _

       vbCritical, «Внимание!»

      txtResCell.SetFocus

      Exit Sub

   ElseIf txtRange.Value = «» Then

      MsgBox «Введите адрес диапазона суммирования», _

       vbCritical, «Внимание!»

      txtRange.SetFocus

      Exit Sub

   End If

   ‘ Формирование формулы

   strFormula = «=ColorCalc(» & «»»» & txtRange.Value & «»»» _

    & «,» & lngCurColor & «,» & CInt(tglType.Value) & «,» _

    & intMode & «,» & CInt(chkVarify.Value) & «)»

   ‘ Запись формулы в ячейку

   Range(txtResCell.Value).Formula = strFormula

End Sub

Sub cmbExit_Click()

   ‘ Закрытие формы

   Unload Me

End Sub

Sub cboCalcTypes_Afterupdаtе()

   ‘ Изменение режима вычисления — сохраним в переменной _

    номер вычисления

   intMode = cboCalcTypes.ListIndex

End Sub

Sub cboOtherColor_Change()

   ‘ Изменение выделенного цвета в списке «Другой»

   If cboOtherColor.Text <> «» Then

      ‘ Сохранение выбранного цвета в переменной

      lngCurColor = Val(cboOtherColor.Value)

   End If

End Sub

Sub tglType_Click()

   ‘ Изменение типа идентификации ячеек

   If tglType.Value = -1 Then

      ‘ Идентификация по цвету заливки

      tglType.Caption = «Заливка»

   Else

      ‘ Идентификация по цвету шрифта

      tglType.Caption = «Шрифт»

   End If

   GetColors

End Sub

Sub txtRange_Afterupdаtе()

   ‘ Изменение диапазона с исходными данными — покажем _

    кнопки с цветами, представленными в новом диапазоне

   GetColors

End Sub

Sub txtRange_Beforeupdаtе(ByVal Cancel As MSForms.ReturnBoolean)

   ‘ Проверка корректности данных, введенных в поле _

    диапазона исходных данных

   Dim rgData As Range

   Dim cell As Range

   ‘ Проверка, введен ли диапазон данных

   If txtRange.Text = «» Then

      MsgBox «Введите адрес диапазона суммирования!», _

       vbCritical, «Ошибка выполнения»

      Cancel = True

   End If

   If txtResCell.Text = «» Then Exit Sub

   On Error GoTo Err1

   ‘ Проверка отсутствия циклических ссылок (чтобы одна _

    из входных ячеек не была одновременно и выходной)

   Set rgData = Range(txtRange.Text)

   For Each cell In rgData.Cells

      If cell.Address(False, False) = _

       Range(txtResCell.Text).Address(False, False) Then

         ‘ Нашли циклическую ссылку

         MsgBox «Введите другой адрес во избежание » & _

          «появления циклических ссылок», vbCritical, _

          «Внимание!»

         Cancel = True

         Exit Sub

      End If

   Next cell

   Exit Sub

Err1:

   ‘ Обработка ошибок при работе с ячейками

   If Err.Number = 1004 Then

      MsgBox «Введите корректный адрес ячейки», vbCritical, _

       «Ошибка ввода»

      Cancel = True

      Exit Sub

   Else

      MsgBox Err.Desсriрtion, vbCritical, «Ошибка ввода»

      Cancel = True

      Exit Sub

   End If

End Sub

Sub txtResCell_Beforeupdаtе(ByVal Cancel As MSForms.ReturnBoolean)

   ‘ Проверка корректности данных, введенных в поле _

    адреса выходной ячейки

   Dim rgData As Range

   Dim cell As Range

   ‘ Проверка, введен ли диапазон данных

   If txtRange.Text = «» Then

      MsgBox «Введите адрес диапазона суммирования!», _

       vbCritical, «Ошибка выполнения»

      Cancel = True

   End If

   If txtResCell.Text = «» Then Exit Sub

   On Error GoTo Err1

   ‘ Проверка отсутствия циклических ссылок (чтобы одна _

    из входных ячеек не была одновременно и выходной)

   Set rgData = Range(txtRange.Text)

   For Each cell In rgData.Cells

      If cell.Address(False, False) = _

       Range(txtResCell.Text).Address(False, False) Then

         ‘ Нашли циклическую ссылку

         MsgBox «Введите другой адрес во избежание » & _

          «появления циклических ссылок», vbCritical, _

          «Внимание!»

         Cancel = True

         Exit Sub

      End If

   Next cell

   Exit Sub

Err1:

   ‘ Обработка ошибок при работе с ячейками

   If Err.Number = 1004 Then

      MsgBox «Введите корректный адрес ячейки», vbCritical, _

       «Ошибка ввода»

      Cancel = True

      Exit Sub

   Else

      MsgBox Err.Desсriрtion, vbCritical, «Ошибка ввода»

      Cancel = True

      Exit Sub

   End If

End Sub

Sub UserForm_Activate()

   ‘ Инициализация формы при активации

   Dim intFunc As Integer

   Dim strFunc As String

   ‘ Заполение списка доступных операций

   cboCalcTypes.AddItem «0»

   cboCalcTypes.List(0, 1) = «Сумма»

   cboCalcTypes.AddItem «1»

   cboCalcTypes.List(1, 1) = «Среднее»

   cboCalcTypes.AddItem «2»

   cboCalcTypes.List(2, 1) = «Максимум»

   cboCalcTypes.AddItem «3»

   cboCalcTypes.List(3, 1) = «Минимум»

   cboCalcTypes.AddItem «4»

   cboCalcTypes.List(4, 1) = «Количество ячеек»

   cboCalcTypes.AddItem «5»

   cboCalcTypes.List(5, 1) = «Сумма положительных»

   cboCalcTypes.AddItem «6»

   cboCalcTypes.List(6, 1) = «Сумма отрицательных»

   cboCalcTypes.AddItem «7»

   cboCalcTypes.List(7, 1) = «Количество непустых»

   cboCalcTypes.AddItem «8»

   cboCalcTypes.List(8, 1) = «Количество непустых ненулевых»

   cboCalcTypes.AddItem «9»

   cboCalcTypes.List(9, 1) = «Количество положительных»

   cboCalcTypes.AddItem «10»

   cboCalcTypes.List(10, 1) = «Количество отрицательных»

   ‘ Заполнение списка дополнительных цветов

   cboOtherColor.AddItem «255»

   cboOtherColor.List(0, 1) = «Красный»

   cboOtherColor.AddItem «52479»

   cboOtherColor.List(1, 1) = «Оранжевый»

   cboOtherColor.AddItem «65535»

   cboOtherColor.List(2, 1) = «Желтый»

   cboOtherColor.AddItem «32768»

   cboOtherColor.List(3, 1) = «Зеленый»

   cboOtherColor.AddItem «16776960»

   cboOtherColor.List(4, 1) = «Голубой»

   cboOtherColor.AddItem «16711680»

   cboOtherColor.List(5, 1) = «Синий»

   cboOtherColor.AddItem «16711935»

   cboOtherColor.List(6, 1) = «Фиолетовый»

   cboOtherColor.AddItem «16777215»

   cboOtherColor.List(7, 1) = «Белый»

   cboOtherColor.AddItem «0»

   cboOtherColor.List(8, 1) = «Черный»

   If Selection.Cells.Count = 1 Then

      ‘ На листе есть выделенная ячейка. Определим, есть ли в этой _

       ячейке формула с функцией ColorCalc

      intFunc = InStr(Selection.Formula, «ColorCalc(«)

      If intFunc > 0 Then

         ‘ Формула есть, заполним поля формы для вычислений

         ‘ Адрес ячейки с результатом

         txtResCell.Text = Selection.Address(False, False)

         ‘ Выделяем аргументы функции…

         ‘ Номера ячеек с исходными данными

         strFunc = Mid(Selection.Formula, intFunc + 11)

         intFunc = InStr(strFunc, «»»»)

         txtRange.Text = Left(strFunc, intFunc — 1)

         ‘ Тип идентификации ячеек (по шрифту или цвету)

         strFunc = Mid(strFunc, intFunc + 2)

         intFunc = InStr(strFunc, «,»)

         strFunc = Mid(strFunc, intFunc + 1)

         intFunc = InStr(strFunc, «,»)

         tglType.Value = Left(strFunc, intFunc — 1)

         ‘ Режим вычислений

         strFunc = Mid(strFunc, intFunc + 1)

         strFunc = Left(strFunc, Len(strFunc) — 1)

         intFunc = InStr(strFunc, «,»)

         cboCalcTypes.Text = cboCalcTypes.List(Val(Left$( _

          strFunc, intFunc — 1)), 1)

         strFunc = Mid(strFunc, intFunc + 1)

         chkVarify.SetFocus

         chkVarify.Value = CBool(strFunc)

         lblChoose.Visible = True

         GetColors

      Else

         ‘ Будем применять формулу для выделенной ячейки

         txtRange.Value = Selection.Address(False, False)

         ‘ В выделенной ячейке конкретная функция не задана. _

          Выберем первую функцию в списке

         cboCalcTypes.Text = «Сумма»

      End If

   Else

      ‘ Будем применять формулу для выделенной ячейки

      txtRange.Value = Selection.Address(False, False)

      ‘ В выделенной ячейке конкретная функция не задана. _

       Выберем первую функцию в списке

      cboCalcTypes.Text = «Сумма»

   End If

End Sub

Sub GetColors()

   ‘ Отображение кнопок выбора цвета окрашенными в цвета, _

    встречающиеся среди ячеек заданного диапазона

   Dim rgCells As Range

   Dim i As Integer

   Dim intColorNumber As Integer   ‘ Номер следующей кнопки _

                                    выбора цвета

   Dim lngCurColor As ****         ‘ Анализируемый цвет

   Dim fColorPresented As Boolean  ‘ Кнопка с цветом _

                                    lngCurColor уже существует

   Dim ctrl As Control

   Dim strCtrl As String

   Dim fBackColor As Boolean       ‘ = True, если ячейки _

                                    идентифицируются по цвету фона, _

                                    = False — по цвету шрифта

   fBackColor = tglType.Value

   On Error Resume Next

   ‘ Скрытие всех кнопок выбора цвета

   For Each ctrl In Me.Controls

      If Left(ctrl.Name, 8) = «cmbColor» Then

         ctrl.Visible = False

      End If

   Next ctrl

   On Error GoTo ErrRange

   Set rgCells = Range(txtRange.Text)

   On Error GoTo 0

   ‘ Получение цвета первой ячейки

   If fBackColor = False Then

      lngCurColor = rgCells.Cells(i).Font.Color

   Else

      lngCurColor = rgCells.Cells(i).Interior.Color

   End If

   ‘ Назначения цвета первой ячейки первой кнопке

   cmbColor1.BackColor = lngCurColor

   cmbColor1.Visible = True

   ‘ Просмотр остальных ячеек и при нахождении новых цветов _

    отображение кнопок, окрашенных в эти цвета

   intColorNumber = 2

   For i = 2 To rgCells.Cells.Count

      fColorPresented = False

      ‘ Получение цвета i-й ячейки

      If fBackColor = False Then

         lngCurColor = rgCells.Cells(i).Font.Color

      Else

         lngCurColor = rgCells.Cells(i).Interior.Color

      End If

      ‘ Проверка, отображается ли уже кнопка с таким цветом

      For Each ctrl In Me.Controls

         If Left(ctrl.Name, 8) = «cmbColor» And _

          ctrl.Visible = True Then

            If lngCurColor = ctrl.BackColor Then

               ‘ Кнопка с цветом i-й ячейки уже отображается

               fColorPresented = True

               Exit For

            End If

         End If

      Next ctrl

      If Not fColorPresented Then

         ‘ Кнопки с цветом lngCurColor еще нет — покажем ее

         intColorNumber = intColorNumber + 1

         strCtrl = «cmbColor» & intColorNumber

         Me.Controls(strCtrl).BackColor = lngCurColor

         Me.Controls(strCtrl).Visible = True

      End If

   Next i

   Exit Sub

ErrRange:

   ‘ Обработка ошибок при работе с диапазоном

   If txtRange.Text = «» Then

      MsgBox «Введите адрес диапазона суммирования», _

       vbCritical, «Внимание!»

   Else

      MsgBox «Введен некорректный адрес диапазона суммирования», _

       vbCritical, «Ошибка!»

   End If

   ‘ Установка курсора в поле ввода диапазона

   txtRange.SetFocus

End Sub

ГЛАВА 11. ДРУГИЕ ФУНКЦИИ И МАКРОСЫ

Вызов функциональных клавиш

Sub Test()

 SendKeys («{F1}»)

End Sub

Расчет среднего арифметического значения

Sub CalculateAverage()

   Dim strFistCell As String

   Dim strLastCell As String

   Dim strFormula As String

   ‘ Условия закрытия процедуры

   If ActiveCell.Row = 1 Then Exit Sub

   ‘ Определение положения первой и последней ячеек для расчета

   strFistCell = ActiveCell.Offset(-1, 0).End(xlUp).Address

   strLastCell = ActiveCell.Offset(-1, 0).Address

   ‘ Формула для расчета среднего значения

   strFormula = «=AVERAGE(» & strFistCell & «:» & strLastCell & «)»

   ‘ Ввод формулы в текущую ячейку

   ActiveCell.Formula = strFormula

End Sub

Перевод чисел в «деньги»

Листинг 2.50. Функция RubKop

Function RubKop(Число)

   ‘ Пустые ячейки и ячейки, содержащие текст, функция _

    не обрабатывает

   If IsNumeric(Число) = False Or Число = «» Then RubKop = _

    «<>»: Exit Function

   ‘ Из числа целой части — рубли

   ДлинаЧисла = Len(Число)

   ЦелаяЧасть = Fix(Число)

   ДлинаЦелой = Len(ЦелаяЧасть)

   ‘ Вычисление длины дробной части

   ДлинаДроби = ДлинаЧисла — ДлинаЦелой

   If ДлинаДроби <> 0 Then

      ДлинаДроби = ДлинаЧисла — ДлинаЦелой — 1

   End If

   ‘ Формирование количества копеек в зависимости от длины _

    дробной части

   If ДлинаДроби = 0 Then

      ‘ Ноль копеек

      Копейки = «00»

   ElseIf ДлинаДроби = 1 Then

      ‘ Дробная часть состоит из одного числа — это _

       десятки копеек

      Копейки = Right(Число, ДлинаДроби) & «0»

   ElseIf ДлинаДроби = 2 Then

      ‘ Дробная часть полностью соответствует количеству копеек

      Копейки = Right(Число, ДлинаДроби)

   Else

      ‘ Длина дробной части больше двух — округлим _

       дробную часть

      Копейки = Right(Число, ДлинаДроби)

      If Mid(Копейки, 3, 1) > 4 Then

         Копейки = Left(Копейки, 2) + 1

      Else

         Копейки = Left(Копейки, 2)

      End If

   End If

   ‘ Составление полной надписи из количества рублей и копеек

   Рубли = ЦелаяЧасть

   RubKop = Рубли & » » & «руб.» & » » & Копейки & » » & «коп.»

End Function

Поиск ближайшего понедельника

Листинг 2.60. Ближайший день недели по отношению к дате

Function dhGetNextMonday(datDate As Date) As Date

   ‘ Определение даты следующего понедельника (функция Weekday _

    возвращает номер дня недели, считая от понедельника, если _

    в качестве второго аргумента задавать vbMonday)

   If Weekday(datDate, vbMonday) = 1 Then

      ‘ Заданная дата и есть понедельник

      dhGetNextMonday = datDate

   Else

      ‘ Расчет даты следующего понедельника

      dhGetNextMonday = datDate + 8 — Weekday(datDate, vbMonday)

   End If

End Function

Подсчет количества полных лет

Листинг 2.61. Функция dhCalculateAge

Function dhCalculateAge(datDate As Date) As ****

   Dim lngAge As ****

   ‘ Находим разность между текущей датой и указанной (лет)

   lngAge = DateDiff(«yyyy», datDate, Date)

   If DateSerial(Year(datDate) + lngAge, Month(datDate), _

    Day(datDate)) > Date Then

      ‘ В этом году день рождения еще не наступил

      lngAge = lngAge — 1

   End If

   dhCalculateAge = lngAge

End Function

Расчет средневзвешенного значения

Листинг 2.63. Расчет средневзвешенного значения

Function dhAverageWithWeight(rgWeights As Range, rgValues As Range) _

 As Double

   If (rgWeights.Count <> rgValues.Count) Then

      ‘ Количество весов не соответствует количеству аргументов

      dhAverageWithWeight = 0

      Exit Function

   End If

   Dim i As Integer

   Dim dblSum As Double        ‘ Сумма значений

   Dim dblSumWeight As Double  ‘ Взвешенная сумма значений

   ‘ Вычисление…

   For i = 1 To rgWeights.Count

      ‘ Взвешенной суммы значений

      dblSumWeight = dblSumWeight + rgWeights(i) * rgValues(i)

      ‘ Суммы значений

      dblSum = dblSum + rgWeights(i)

   Next

   ‘ Возвращение средневзвешенного значения

   dhAverageWithWeight = dblSumWeight / dblSum

End Function

Преобразование номера месяца в его название

Листинг 2.64. Название месяца

Function dhMonthName(intMonth As Integer) As String

   ‘ Возвращение имени месяца по его номеру (intMonth _

    является номером элемента в массиве с названиями месяцев)

   dhMonthName = Choose(intMonth, «Январь», «Февраль», «Март», _

    «Апрель», «Май», «Июнь», «Июль», «Август», «Сентябрь», _

    «Октябрь», «Ноябрь», «Декабрь»)

End Function

Использование относительных ссылок

Листинг 2.73. Функция dhSheetOffset

Function dhSheetOffset(offset As Integer, cell As Range) As Variant

   ‘ Возврат корректного значения ячейки cell листа, смещение _

    которого относительно текущего задано переменной offset

   dhSheetOffset = Sheets(Application.Caller.Parent.Index _

    + offset).Range(cell.Address)

End Function

Листинг 2.74. Функция dhSheetOffset2

Function dhSheetOffset2(offset As Integer, cell As Range) As Variant

   ‘ Корректировка смещения (чтобы ссылка была на рабочий лист)

   Do While TypeName(Sheets(cell.Parent.Index + offset)) _

    <> «Worksheet»

      If offset > 0 Then

         ‘ Пропускаем лист и проходим вперед по книге

         offset = offset + 1

      Else

         ‘ Пропускаем лист и проходим назад по книге

         offset = offset — 1

      End If

   Loop

   ‘ Возврат корректного значения ячейки cell листа, смещение _

    которого относительно текущего задано переменной offset _

    с пропуском листов с диаграммами

   dhSheetOffset2 = Sheets(cell.Parent.Index _

    + offset).Range(cell.Address)

End Function

Преобразование таблицы Excel в HТМL-формат

Листинг 3.60. Преобразование таблицы в HТМL-формат

Sub ExportAsHТМL()

   Dim strStyle As String     ‘ Параметры стиля отображения ячейки

   Dim strAlign As String     ‘ Параметры выравнивания ячейки

   Dim strOut As String       ‘ Выходная строка с HТМL-кодом

   Dim cell As Object         ‘ Обрабатываемая ячейка

   Dim strCellText As String  ‘ Текст обрабатываемой ячейки

   Dim lngRow As ****         ‘ Номер строки обрабатываемой ячейки

   Dim lngLastRow As ****     ‘ Номер строки предыдущей ячейки

   Dim strTemp As String

   Dim objWordApp As Object

   Dim i As ****

   lngLastRow = Selection.Row

   ‘ Просмотр всех выделенных ячеек

    For Each cell In Selection

      ‘ Значение строки для рассматриваемой ячейки

      lngRow = cell.Row

      ‘ Если перешли на другую строку, то вставляем <tr>

      If lngRow <> lngLastRow Then

         strOut = strOut & vbTab & «</tr>» & vbCrLf & vbTab & _

          «<tr>» & vbCrLf

         ‘ Переход на следующую строку

         lngLastRow = lngRow

      End If

      ‘ Задание шрифта ячейки

      If Not IsNull(cell.Font.Size) Then

         strStyle = » style=» & «font-size: » & Int(100 * _

          cell.Font.Size / 19) & «%;»

      End If

      ‘ Для полужирного шрифта вставляем <b>

      If cell.Font.Bold Then

         strCellText = «<b>» & strCellText & «</b>»

      End If

      ‘ Задание выравнивания

      If cell.HorizontalAlignment = xlRight Then

         ‘ По правому краю

         strAlign = » align=» & «right»

      ElseIf cell.HorizontalAlignment = xlCenter Then

         ‘ По центру

         strAlign = » align=» & «center»

      Else

         ‘ По левому краю (по умолчанию)

         strAlign = «»

      End If

      ‘ Чтение текста в ячейке

      strCellText = cell.Text

      ‘ Если нужно, то вертикальный вывод текста (в строку strTemp _

       с последующим перенесением обратно в strCellText)

      If cell.Orientation <> xlHorizontal Then

         strTemp = «»

         ‘ Печать после каждого символа специального _

          разделителя — <br>

         For i = 1 To Len(strCellText)

            strTemp = strTemp & Mid$(strCellText, i, 1) & «<br>»

         Next i

         strCellText = strTemp

         strStyle = «»

      End If

      strOut = strOut & vbTab & vbTab & «<td» & strStyle & strAlign _

       & «>» & strCellText & «</td>» & vbCrLf

   Next

   ‘ Вставка <tr> для первой строки и </tr> — для последней

   strOut = vbTab & «<tr>» & vbCrLf & strOut & vbTab & «</tr>» & vbCrLf

   ‘ Вставка дескриптора <table>

   strOut = «<table border=1 cellpadding=3 cellspacing=1>» & vbCrLf & _

    strOut & vbCrLf & «</table>»

   ‘ Запускаем Word и показываем в нем сформированный HТМL-код

   Set objWordApp = CreateObject(«Word.Application»)

   objWordApp.documents.Add

   objWordApp.Selection = strOut

   objWordApp.Selection.Copy

   objWordApp.Visible = True

   Set objWordApp = Nothing

End Sub

Генератор случайных чисел

Листинг 2.77. Функция dhGetRandomValues

Function dhGetRandomValues() As Variant

   Dim intRow As Integer       ‘ Номер текущей строки

   Dim intCol As Integer       ‘ Номер текущего столбца

   Dim aintOut() As Integer    ‘ Выходной массив (двумерный)

   Dim aintValues() As Integer ‘ Массив с возможными значениями

   Dim intMax As Integer       ‘ Последний доступный элемент массива _

                                aintValues

   Dim i As Integer

   ReDim aintOut(1 To Application.Caller.Rows.Count, 1 To _

    Application.Caller.Columns.Count)

   ‘ Всего нужно чисел…

   intMax = Application.Caller.Rows.Count * _

    Application.Caller.Columns.Count

   ReDim aintValues(1 To intMax)

   ‘ Заполнение массива aintValues значениями от 1 до intMax

   For i = 1 To intMax

      aintValues(i) = i

   Next i

   ‘ Занесение значений в выходной массив aintOut, в произвольном _

    порядке выбирая их из aintValues

   Randomize

   For intRow = 1 To Application.Caller.Rows.Count

      For intCol = 1 To Application.Caller.Columns.Count

         ‘ Определение номера элемента из aintValues

         i = Rnd * intMax

         If i = 0 Then i = 1

         ‘ Занесение этого элемента в выходной массив

         aintOut(intRow, intCol) = aintValues(i)

         ‘ Уменьшение массива aintValues (то есть еще один его _

          элемент выбран) — замена выбранного элемента последним _

          в массиве

         aintValues(i) = aintValues(intMax)

         intMax = intMax — 1

      Next intCol

   Next intRow

   ‘ Возвращение массива значений

   dhGetRandomValues = aintOut

End Function

Случайные числа — на основании диапазона

Листинг 2.78. Функция dhGetRandomValues1

Function dhGetRandomValues1(rgSource As Range) As Variant

   Dim intRow As Integer       ‘ Номер текущей строки

   Dim intCol As Integer       ‘ Номер текущего столбца

   Dim avarOut() As Variant    ‘ Выходной массив (двумерный)

   Dim avarValues() As Variant ‘ Массив с возможными значениями

   Dim intValCount As Integer  ‘ Количество возможных значений

   Dim cell As Range

   Dim i As Integer

   ReDim avarOut(1 To Application.Caller.Rows.Count, 1 To _

    Application.Caller.Columns.Count)

   ‘ Всего нужно чисел…

   intValCount = rgSource.Rows.Count * rgSource.Columns.Count

   ReDim avarValues(1 To intValCount)

   ‘ Заполнение массива avarValues значениями из указанного _

    диапазона

   For Each cell In rgSource

      i = i + 1

      avarValues(i) = cell.Value

   Next cell

   ‘ Занесение значений в выходной массив avarOut, в произвольном _

    порядке выбирая их из avarValues

   Randomize

   For intRow = 1 To Application.Caller.Rows.Count

      For intCol = 1 To Application.Caller.Columns.Count

         ‘ Определение номера элемента из avarValues

         i = Rnd * intValCount

         If i = 0 Then i = 1

         ‘ Занесение этого элемента в выходной массив

         avarOut(intRow, intCol) = avarValues(i)

      Next intCol

   Next intRow

   ‘ Возвращение массива значений

   dhGetRandomValues1 = avarOut

End Function

Применение функции без ввода ее в ячейку

Листинг 3.14. Применение функции без ввода в ячейку

Sub Func()

   [A1] = Application.Sum([B5:B10])

End Sub

Подсчет именованных объектов

Листинг 3.29. Количество именованных объектов

Sub CountNames()

   Dim intNamesCount As Integer

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

    рабочей книге

   intNamesCount = ActiveWorkbook.Names.Count

   If intNamesCount = 0 Then

      MsgBox «Имен нет»

   Else

      MsgBox «Имен: » & intNamesCount & » шт.»

   End If

End Sub

Включение автофильтра с помощью макроса

Листинг 3.63. Включение автофильтра

Sub EnableAutoFilter()

   On Error Resume Next

   Selection.AutoFilter

End Sub

Создание бегущей строки

Листинг 3.76. Создание бегущей строки

Dim intSpacesLeft As Integer  ‘ Количество пробелов в начале строки

Sub Start()

   ‘ Установка начального количества пробелов

   intSpacesLeft = 10

   ‘ Первый вызов функции бегущей строки

   MovingString

End Sub

Sub MovingString()

   If intSpacesLeft >= 0 Then

      ‘ Отображение строки

      Range(«A1»).Value = Space(intSpacesLeft) & «Привет!»

      intSpacesLeft = intSpacesLeft — 1

      ‘ Указывем Excel, что данную процедуру нужно вызвать через _

       1 секунду

      Application.OnTime Now + TimeValue(«00:00:01»), «MovingString»

   End If

End Sub

Создание бегущей картинки

Листинг 3.77. Бегущая картинка

Sub MovingImage()

   Dim i As Integer

   Dim image As Object

   ‘ Создание изображения (в ячейке «A1»)

   With Range(«A1»)

      ‘ Формирование значения в ячейке:

      ‘ текст

      .Value = «Привет!»

      ‘ полужирный шрифт

      .Font.Bold = True

      ‘ цвет

      .Font.Color = RGB(233, 133, 229)

      ‘ размер шрифта

      .Font.Size = 16

      ‘ угол наклона

      .Orientation = 30

      ‘ Отображение текста полностью

      .EntireColumn.AutoFit

      ‘ Копирование в буфер обмена

      .Copy

      ‘ Создание самостоятельного изображения (на основе _

       скопированных в буфер обмена данных)

      Set image = ActiveSheet.Pictures.Paste(Link:=False)

      ‘ Содержимое ячейки больше не нужно

      .Clear

   End With

   ‘ Задание начального положения изображения (левый верхний _

    угол листа)

   With image

      .Top = 0

      .Left = 0

   End With

   MsgBox «ПУСК!»

   With image

      ‘ Перемещение изображения по диагонали

      For i = 0 To 100

         .Top = i

         .Left = i

      Next

      ‘ Удаление изображения

      .Delete

   End With

   ‘ Удаление ссылки на изображение

   Set image = Nothing

End Sub

Вращающиеся автофигуры

Листинг 3.79. Вращение автофигур

Sub RotatingAutoShapes()

   Static fRunning As Boolean

   ‘ Проверка, выполняется ли уже этот макрос

   If fRunning Then

      ‘ При повторном запуске останавливаем все запущенные макросы

      fRunning = False

      End

   End If

   ‘ Укажем, что макрос запущен

   fRunning = True

   Dim cell As Range                  ‘ Рабочая ячейка

   Dim intLeftBorder As ****          ‘ Левая граница ячейки

   Dim intRightBorder As ****         ‘ Правая граница ячейки

   Dim intTopBorder As ****           ‘ Верхняя граница ячейки

   Dim intBottomBorder As ****        ‘ Нижняя граница ячейки

   Dim alngVertSpeed(1 To 2) As ****  ‘ Массивы со значениями

   Dim alngHorzSpeed(1 To 2) As ****  ‘ горизонтальной и вертикальной

                                      ‘ составляющих скоростей фигур

   Dim ashShapes(1 To 2) As Shape     ‘ Массив перемещаемых автофигур

   Dim i As Integer

   ‘ Заполнение массива автофигур

   Set ashShapes(1) = ActiveSheet.shapes(1)

   Set ashShapes(2) = ActiveSheet.shapes(2)

   ‘ Заполнение массива скоростей:

   ‘ для первой фигуры

   alngVertSpeed(1) = 3

   alngHorzSpeed(1) = 3

   ‘ для второй фигуры

   alngVertSpeed(2) = 4

   alngHorzSpeed(2) = 4

   ‘ Получение границ рабочей ячейки

   Set cell = Range(«B2»)

   intLeftBorder = cell.Left

   intRightBorder = cell.Left + cell.Width

   intTopBorder = cell.Top

   intBottomBorder = cell.Top + cell.Height

   ‘ Выполнение вращения и перемещения фигур

   Do

      ‘ Изменение положения каждой автофигуры

      For i = 1 To 2

         With ashShapes(i)

            ‘ Контроль достижения правой границы ячейки

            If .Left + .Width + alngHorzSpeed(i) > intRightBorder Then

               ‘ Корректировка положения

               .Left = intRightBorder — .Width

               ‘ Изменение направления горизонтальной скорости _

                на противоположное

               alngHorzSpeed(i) = -alngHorzSpeed(i)

            End If

            ‘ Контроль достижения левой границы ячейки

            If .Left + alngHorzSpeed(i) < intLeftBorder Then

               ‘ Корректировка положения

               .Left = intLeftBorder

               ‘ Изменение направления горизонтальной скорости _

                на противоположное

               alngHorzSpeed(i) = -alngHorzSpeed(i)

            End If

            ‘ Контроль достижения нижней границы ячейки

            If .Top + .Height + alngVertSpeed(i) > intBottomBorder Then

               ‘ Корректировка положения

               .Top = intBottomBorder — .Height

               ‘ Изменение направления вертикальной скорости _

                на противоположное

               alngVertSpeed(i) = -alngVertSpeed(i)

            End If

            ‘ Контроль достижения верхней границы ячейки

            If .Top + alngVertSpeed(i) < intTopBorder Then

               ‘ Корректировка положения

               .Top = intTopBorder

               ‘ Изменение направления вертикальной скорости _

                на противоположное

               alngVertSpeed(i) = -alngVertSpeed(i)

            End If

            ‘ Перемещение автофигуры

            .Left = .Left + alngHorzSpeed(i)

            .Top = .Top + alngVertSpeed(i)

            ‘ Вращение автофигуры (изменение направления вращения _

             происходит каждый раз при изменении направления _

             вертикального перемещения)

            .IncrementRotation alngVertSpeed(i)

            ‘ Даем Excel команду обработать пользовательский ввод

            DoEvents

         End With

      Next

   Loop

End Sub

Вызов таблицы цветов

Листинг 3.80. Отображение таблицы цветов

Sub ShowColorTable()

   Dim intColor As Integer

   ‘ Формирование заголовка таблицы

   Range(«A1»).Value = «Цвет»

   Range(«B1»).Value = «Значение свойства ColorIndex»

   ‘ Вывод таблицы

   Range(«A2»).Select

   For intColor = 1 To 56

      ‘ Окрашиваем ячейку столбца «A» в текущий цвет

      With ActiveCell.Interior

         .ColorIndex = intColor

         .Pattern = xlSolid

         .PatternColorIndex = xlAutomatic

      End With

      ‘ В ячейку столбца «B» вносим индекс текущего цвета

      ActiveCell.Offset(0, 1).Value = intColor

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

      ActiveCell.Offset(1, 0).Activate

   Next

   ‘ Покажем ячейку «A1» (начало таблицы)

   Range(«A1»).Select

   ActiveWindow.ScrollRow = 1

End Sub

Создание калькулятора

Листинг 3.81. Создание калькулятора

Sub SimpleCalculator()

   Dim strExpr As String

   ‘ Ввод выражения

   strExpr = InputBox(«Что будем считать?»)

   ‘ Подсчет и вывод результата

   MsgBox strExpr & » = » & Application.Evaluate(strExpr)

End Sub

Склонение фамилии, имени и отчества

Листинг 3.85. Склонение ФИО

Public Sub PossessiveCase()

   ‘ Склоняем ФИО в родительный падеж

   Dim strName1 As String, strName2 As String, strName3 As String

   strName1 = dhGetName(ActiveCell, 1)  ‘ Выделяем имя

   strName2 = dhGetName(ActiveCell, 2)  ‘ Выделяем фамилию

   strName3 = dhGetName(ActiveCell, 3)  ‘ Выделяем отчество

   ‘ Если в ячейке менее трех слов — закрытие процедуры

   If strName1 = «» Or strName2 = «» Or strName3 = «» Then Exit Sub

   ‘ Склоняем

   Cells(ActiveCell.Row, ActiveCell.Column) = dhPossessive( _

    strName1, strName2, strName3)

End Sub

Public Sub DativeCase()

   ‘ Объявление переменных

   Dim strName1 As String, strName2 As String, strName3 As String

   strName1 = dhGetName(ActiveCell, 1)

   strName2 = dhGetName(ActiveCell, 2)

   strName3 = dhGetName(ActiveCell, 3)

   ‘ Если в ячейке менее трех слов — закрытие процедуры

   If Len(strName1) = 0 Or Len(strName2) = 0 Or Len(strName3) = 0 _

    Then Exit Sub

   Cells(ActiveCell.Row, ActiveCell.Column) = dhDative( _

    strName1, strName2, strName3)

End Sub

Function dhPossessive(strName1 As String, strName2 As String, _

 strName3 As String) As String

   Dim fMan As Boolean

   ‘ Определяем, мужские ФИО или женские

   fMan = (Right(strName3, 1) = «ч»)

   ‘ Склонение фамилии в родительный падеж

   If Len(strName1) > 0 Then

      If fMan Then

         ‘ Склонение мужской фамилии

         Select Case Right(strName1, 1)

            Case «о», «и», «я», «а»

               dhPossessive = strName1

            Case «й»

               dhPossessive = Mid(strName1, 1, Len(strName1) — 2) + «ого»

            Case Else

               dhPossessive = strName1 + «а»

         End Select

      Else

         ‘ Склонение женской фамилии

         Select Case Right(strName1, 1)

            Case «о», «и», «б», «в», «г», «д», «ж», «з», «к», «л», _

             «м», «н», «п», «р», «с», «т», «ф», «х», «ц», «ч», _

             «ш», «щ», «ь»

               dhPossessive = strName1

            Case «я»

               dhPossessive = Mid(strName1, 1, Len(strName1) — 2) & «ой»

            Case Else

               dhPossessive = Mid(strName1, 1, Len(strName1) — 1) & «ой»

         End Select

      End If

      dhPossessive = dhPossessive & » »

   End If

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

   If Len(strName2) > 0 Then

      If fMan Then

         ‘ Склонение мужского имени

         Select Case Right(strName2, 1)

            Case «й», «ь»

               dhPossessive = dhPossessive & Mid(strName2, _

                1, Len(strName2) — 1) & «я»

            Case Else

               dhPossessive = dhPossessive & strName2 & «а»

         End Select

      Else

         ‘ Склонение женского имени

         Select Case Right(strName2, 1)

            Case «а»

               Select Case Mid(strName2, Len(strName2) — 1, 1)

                  Case «и», «г»

                     dhPossessive = dhPossessive & Mid( _

                      strName2, 1, Len(strName2) — 1) & «и»

                  Case Else

                     dhPossessive = dhPossessive & Mid(strName2, _

                      1, Len(strName2) — 1) & «ы»

               End Select

            Case «я»

               If Mid(strName2, Len(strName2) — 1, 1) = «и» Then

                  dhPossessive = dhPossessive & Mid(strName2, _

                   1, Len(strName2) — 1) & «и»

               Else

                  dhPossessive = dhPossessive & Mid(strName2, _

                   1, Len(strName2) — 1) & «и»

               End If

            Case «ь»

               dhPossessive = dhPossessive & Mid(strName2, _

                1, Len(strName2) — 1) & «и»

            Case Else

               dhPossessive = dhPossessive & strName2

         End Select

      End If

      dhPossessive = dhPossessive & » »

   End If

   ‘ Склонение отчества в родительный падеж

   If Len(strName3) > 0 Then

      If fMan Then

         dhPossessive = dhPossessive & strName3 & «а»

      Else

         dhPossessive = dhPossessive & Mid(strName3, 1, _

          Len(strName3) — 1) & «ы»

      End If

   End If

End Function

Function dhDative(strName1 As String, strName2 As String, _

 strName3 As String) As String

   Dim fMan As Boolean

   ‘ Определяем, мужские ФИО или женские

   fMan = (Right(strName3, 1) = «ч»)

   ‘ Склонение фамилии в дательный падеж

   If Len(strName1) > 0 Then

      If fMan Then

         ‘ Склонение мужской фамилии

         Select Case Right(strName1, 1)

            Case «о», «и», «я», «а»

               dhDative = strName1

            Case «й»

               dhDative = Mid(strName1, 1, Len(strName1) — 2) + «ому»

            Case Else

               dhDative = strName1 + «у»

         End Select

      Else

         ‘ Склонение женской фамилии

         Select Case Right(strName1, 1)

            Case «о», «и», «б», «в», «г», «д», «ж», «з», «к», «л», _

             «м», «н», «п», «р», «с», «т», «ф», «х», «ц», «ч», «ш», _

             «щ», «ь»

               dhDative = strName1

            Case «я»

               dhDative = Mid(strName1, 1, Len(strName1) — 2) & «ой»

            Case Else

               dhDative = Mid(strName1, 1, Len(strName1) — 1) & «ой»

         End Select

      End If

      dhDative = dhDative & » »

   End If

   ‘ Склонение имени в дательный падеж

   If Len(strName2) > 0 Then

      If fMan Then

         ‘ Склонение мужского имени

         Select Case Right(strName2, 1)

            Case «й», «ь»

               dhDative = dhDative & Mid(strName2, 1, _

                Len(strName2) — 1) & «ю»

            Case Else

               dhDative = dhDative & strName2 & «у»

         End Select

      Else

         ‘ Склонение женского имени

         Select Case Right(strName2, 1)

            Case «а», «я»

               If Mid(strName2, Len(strName2) — 1, 1) = «и» Then

                  dhDative = dhDative & Mid(strName2, 1, _

                   Len(strName2) — 1) & «и»

               Else

                  dhDative = dhDative & Mid(strName2, 1, _

                   Len(strName2) — 1) & «е»

               End If

            Case «ь»

               dhDative = dhDative & Mid(strName2, 1, _

                Len(strName2) — 1) & «и»

            Case Else

               dhDative = dhDative & strName2

         End Select

      End If

      dhDative = dhDative & » »

   End If

   ‘ Склонение отчества в дательный падеж

   If Len(strName3) > 0 Then

      If fMan Then

         dhDative = dhDative & strName3 & «у»

      Else

         dhDative = dhDative & Mid(strName3, 1, Len(strName3) — 1) & «е»

      End If

   End If

End Function

Function dhGetName(strString As String, intNum As Integer)

   ‘ Функция возвращает слово с номером intNum во входной строке _

    strString

   Dim strTemp As String

   Dim intWord As Integer

   Dim intSpace As Integer

   ‘ Удаление пробелов по краям строки

   strTemp = Trim(strString)

   ‘ Просмотр строки (до слова с нужным номером)

   For intWord = 1 To intNum — 1

      ‘ Поиск следующего пробела

      intSpace = InStr(strTemp, » «)

      If intSpace = 0 Then

         ‘ Строка закончилась

         intSpace = Len(strTemp)

      End If

      ‘ Строка strTemp теперь начинается со слова с номером intWord

      strTemp = Trim(Right(strTemp, Len(strTemp) — intSpace))

   Next intWord

   ‘ Выделение нужного слова (по пробелу после него)

   intSpace = InStr(strTemp, » «)

   If intSpace = 0 Then

      intSpace = Len(strTemp)

   End If

   dhGetName = Trim(Left(strTemp, intSpace))

End Function

ГЛАВА 12. ДАТА И ВРЕМЯ

Вывод даты и времени_1

Sub Test()

 Dim MyDate As Date

 MyDate = DateValue(«6/1/72») + TimeValue(«10:10:12»)

 MsgBox Str(Minute(MyDate))

 MsgBox Str(Year(MyDate))

End Sub

Вывод даты и времени_2

Sub TimeAndDate()

   Dim strDate As String, strTime As String

   Dim strGreeting As String

   Dim strUserName As String

   Dim intSpacePos As Integer

   strDate = Format(Date, «**** Date»)

   strTime = Format(Time, «Medium Time»)

   ‘ Приветствие — в зависимости от времени суток

   If Time < TimeValue(«12:00») Then

      strGreeting = «Доброе утро, »

   ElseIf Time < TimeValue(«17:00») Then

      strGreeting = «Добрый день, »

   Else

      strGreeting = «Добрый вечер, »

   End If

   ‘ В приветствие добавляется имя текущего пользователя

   strUserName = Application.UserName

   intSpacePos = InStr(1, strUserName, » «, 1)

   ‘ Управление ситуацией, когда в имени нет пробела

   If intSpacePos = 0 Then intSpacePos = Len(strUserName)

   strGreeting = strGreeting & Left(strUserName, intSpacePos)

   ‘ Вывод на экран информационного сообщения о дате и времени

   MsgBox strDate & vbCrLf & strTime, vbOKOnly, strGreeting

End Sub

Получение системной даты

Извлечение даты и часов

Month(переменная типа Date)

Day(переменная типа Date)

Year(переменная типа Date)

Hour(переменная типа Date)

Minute(переменная типа Date)

Second(переменная типа Date)

WeekDay(переменная типа Date)

WeekDay это день недели, если Вам это нужно, то вы можете написать что-то типа этого.

Sub Test()

 Dim MyDate As Date

 MyDate = DateValue(«9/1/72»)

 If (WeekDay(MyDate) = vbSunday) Then MsgBox («Sunday»)

End Sub

vbSunday это константа , есть еще vbMonday , ну дальше понятно.

Функция ДатаПолная

Function ДатаПолная(Ячейка)

   ‘ Получение данных в заданной ячейке в формате _

    «dd mmmm yyyy»

   Дата = Format(Ячейка, «dd mmmm yyyy»)

   If IsDate(Ячейка) = True Or IsDate(Дата) = True Then

      ‘ Возврат строки с полной датой

      ДатаПолная = StrConv(Дата, vbProperCase)

   Else

      ‘ Данные в ячейке не являются датой

      ДатаПолная = «<>»

   End If

End Function

Содержание

  1. Способы записи макросов в Excel
  2. Создание макросов
  3. Создать макрос в Excel с помощью макрорекордера
  4. Написание макросов в Excel
  5. Настройка разрешения для использования макросов в Excel
  6. Вариант 1: Автоматическая запись макросов
  7. Запуск макроса
  8. Редактирование макроса
  9. Создание кнопки для запуска макросов в панели инструментов
  10. Создание графической кнопки на листе Excel
  11. Чтобы записать макрос, следует:
  12. Отображение вкладки “Разработчик” в ленте меню
  13. Абсолютная и относительная запись макроса
  14. Расширение файлов Excel, которые содержат макросы
  15. Что нельзя сделать с помощью макрорекодера?
  16. Редактор Visual Basic
  17. Запускаем выполнение макроса
  18. Корректируем макрос

Макрос записывается двумя способами: автоматически и вручную. Воспользовавшись первым вариантом, вы просто записываете определенные действия в Microsoft Excel, которые выполняете в данный момент времени. Потом можно будет воспроизвести эту запись. Такой метод очень легкий и не требует знания кода, но применение его на практике довольно ограничено. Ручная запись, наоборот, требует знаний программирования, так как код набирается вручную с клавиатуры. Однако грамотно написанный таким образом код может значительно ускорить выполнение процессов.

Создание макросов

В Эксель создать макросы можно вручную или автоматически. Последний вариант предполагает запись действий, которые мы выполняем в программе, для их дальнейшего повтора. Это достаточно простой способ, пользователь не должен обладать какими-то навыками кодирования и т.д. Однако, в связи с этим, применить его можно не всегда.

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

Создать макрос в Excel с помощью макрорекордера

Для начала проясним, что собой представляет макрорекордер и при чём тут макрос.

Макрорекордер – это вшитая в Excel небольшая программка, которая интерпретирует любое действие пользователя в кодах языка программирования VBA и записывает в программный модуль команды, которые получились в процессе работы. То есть, если мы при включенном макрорекордере, создадим нужный нам ежедневный отчёт, то макрорекордер всё запишет в своих командах пошагово и как итог создаст макрос, который будет создавать ежедневный отчёт автоматически.

Этот способ очень полезен тем, кто не владеет навыками и знаниями работы в языковой среде VBA. Но такая легкость в исполнении и записи макроса имеет свои минусы, как и плюсы:

  • Записать макрорекордер может только то, что может пощупать, а значит записывать действия он может только в том случае, когда используются кнопки, иконки, команды меню и всё в этом духе, такие варианты как сортировка по цвету для него недоступна;
  • В случае, когда в период записи была допущена ошибка, она также запишется. Но можно кнопкой отмены последнего действия, стереть последнюю команду которую вы неправильно записали на VBA;
  • Запись в макрорекордере проводится только в границах окна MS Excel и в случае, когда вы закроете программу или включите другую, запись будет остановлена и перестанет выполняться.

Для включения макрорекордера на запись необходимо произвести следующие действия:

  • в версии Excel от 2007 и к более новым вам нужно на вкладке «Разработчик» нажать кнопочку «Запись макроса»
  • в версиях Excel от 2003 и к более старым (они еще очень часто используются) вам нужно в меню «Сервис» выбрать пункт «Макрос» и нажать кнопку «Начать запись».

Следующим шагом в работе с макрорекордером станет настройка его параметров для дальнейшей записи макроса, это можно произвести в окне «Запись макроса», где:

  • поле «Имя макроса» — можете прописать понятное вам имя на любом языке, но должно начинаться с буквы и не содержать в себе знаком препинания и пробелы;
  • поле «Сочетание клавиш» — будет вами использоваться, в дальнейшем, для быстрого старта вашего макроса. В случае, когда вам нужно будет прописать новое сочетание горячих клавиш, то эта возможность будет доступна в меню «Сервис» — «Макрос» — «Макросы» — «Выполнить» или же на вкладке «Разработчик» нажав кнопочку «Макросы»
  • поле «Сохранить в…» — вы можете задать то место, куда будет сохранен (но не послан) текст макроса, а это 3 варианта:
    • «Эта книга» — макрос будет записан в модуль текущей книги и сможет быть выполнен только в случае, когда данная книга Excel будет открыта;
    • «Новая книга» — макрос будет сохранен в тот шаблон, на основе которого в Excel создается пустая новая книга, а это значит, что макрос станет доступен во всех книгах, которые будут создаваться на этом компьютере с этого момента;
    • «Личная книга макросов» — является специальной книгой макросов Excel, которая называется «Personal.xls» и используется как специальное хранилище-библиотека макросов. При старте макросы из книги «Personal.xls» загружаются в память и могут быть запущены в любой книге в любой момент.

  • поле «Описание» — здесь вы можете описать, что и как должен делать макрос, для чего он создавался и какие функции несет, это чисто информативное поле, что называется на память.

После того как вы запустили и записали свой макрос, выполнив все нужные действия, запись можно прекратить командой «Остановить запись» и ваш макрос с помощью макрорекордера будет создан.

Написание макросов в Excel

Код макроса Excel написанный на языке Visual Basic for Application (VBA), а его выполняет инструмент приложения, к которому он присоединен. Большинство этих инструментов не доступно на уровне окна программы Excel. Как написать макрос.

Теперь продемонстрируем на примере информацию о том, как писать, редактировать и выполнять код макроса.

Чтобы написать макрос:

  1. Откройте рабочую книгу Excel, в которой необходимо использовать макрос: «РАЗРАБОТЧИК»-«Код»-«Visual Basic». Или нажмите комбинацию горячих клавиш ALT+F11.
  2. Перед началом работы в редакторе следует сделать простую настройку. Выберите инструмент в редакторе Visual Basic: «Tools»-«Options». И на вкладке «Editor» активируйте опцию «Require Variable Declaration». Это позволит реализовать автоматическое заполнение инструкций Options Explicit в начале каждого ново созданного кода. А в поле ввода «Tab Width:» укажите значение 2 вместо 4-х. Это позволит уменьшить ширину кода. Данная настройка редактора распространяется на все листы, но в границах одной рабочей книги.
  3. Выберите инструмент: «Insert»-«Module» чтобы создать новый стандартный модуль для макросов. В появившемся окне модуля под текстом Option Explicit введите следующий код макроса:
  4. SubMyMakros()
    DimpolzovatelAs String
    Dimdata_segodnyaAs Date
    polzovatel = Application.UserName
    data_segodnya = Now
    MsgBox"Макрос запустил пользователь: "& polzovatel & vbNewLine & data_segodnya
    End Sub

  5. Нажмите на кнопку в редакторе «Run Macro» или клавишу F5 на клавиатуре. В появившемся окне «Macros» нажмите на кнопку «Run», чтобы посмотреть результат работы макроса.

Примечание. Если в главном меню отсутствует закладка «РАЗРАБОТЧИК», тогда ее необходимо активировать в настройках: «ФАЙЛ»-«Параметры»-«Настроить ленту». В правом списке «Основные вкладки:» активируйте галочкой опцию «Разработчик» и нажмите на кнопку ОК.

Настройка разрешения для использования макросов в Excel

В Excel предусмотрена встроенная защита от вирусов, которые могут проникнуть в компьютер через макросы. Если хотите запустить в книге Excel макрос, убедитесь, что параметры безопасности настроены правильно.

Вариант 1: Автоматическая запись макросов

Прежде чем начать автоматическую запись макросов, нужно включить их в программе Microsoft Excel. Для этого воспользуйтесь нашим отдельным материалом.

Подробнее: Включение и отключение макросов в Microsoft Excel

Когда все готово, приступаем к записи.

  1. Перейдите на вкладку «Разработчик». Кликните по кнопке «Запись макроса», которая расположена на ленте в блоке инструментов «Код».
  2. Открывается окно настройки записи макроса. Тут можно указать любое имя для него, если установленное по умолчанию вас не устраивает. Главное, чтобы имя это начиналось с буквы, а не с цифры, а также в названии не должно быть пробелов. Мы оставили название по умолчанию – «Макрос1».
  3. Тут же при желании можно установить сочетание клавиш, при нажатии на которые макрос будет запускаться. Первой клавишей обязательно должна быть Ctrl, а вторую пользователь устанавливает самостоятельно. Мы в качестве примера установили клавишу М.
  4. Далее следует определить, где будет храниться макрос. По умолчанию он расположен в этой же книге (файле), но при желании можно установить хранение в новой книге или в отдельной книге макросов. Мы оставим значение по умолчанию.
  5. В самом нижнем поле можно оставить любое подходящее по контексту описание макроса, но это делать не обязательно. Когда все настройки выполнены, жмем на кнопку «OK».
  6. После этого все ваши действия в данной книге (файле) Excel будут записываться в макрос до тех пор, пока вы сами не остановите запись.
  7. Для примера запишем простейшее арифметическое действие: сложение содержимого трех ячеек (=C4+C5+C6).
  8. Когда алгоритм был выполнен, щелкаем на кнопку «Остановить запись». Эта кнопка преобразовалась из кнопки «Запись макроса» после включения записи.

Запуск макроса

Для проверки того, как работает записанный макрос, выполним несколько простых действий.

  1. Кликаем в том же блоке инструментов «Код» по кнопке «Макросы» или жмем сочетание клавиш Alt + F8.
  2. После этого открывается окно со списком записанных макросов. Ищем макрос, который мы записали, выделяем его и кликаем на кнопку «Выполнить».
  3. Можно поступить еще проще и не вызывать даже окно выбора макросов, так как на первом этапе мы задали сочетание клавиш для быстрого вызова макроса. В нашем случае это Ctrl + М. Жмем данную комбинацию на клавиатуре, после чего он запускается.
  4. Как видим, он выполнил в точности все те действия, которые были записаны ранее.

Редактирование макроса

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

  1. Снова щелкаем на кнопку «Макросы». В открывшемся окне выбираем нужный и кликаем по кнопке «Изменить».
  2. Открывается «Microsoft Visual Basic» (VBE) – среда, где происходит их редактирование.
  3. Запись каждого макроса начинается с команды Sub, а заканчивается командой End Sub. Сразу же после Sub указывается имя макроса. Оператор Range("…").Select указывает выбор ячейки. Например, при команде «Range(«C4»).Select» выбирается ячейка «C4». Оператор ActiveCell.FormulaR1C1 используется для записи действий в формулах и других расчетов.
  4. Попытаемся немного изменить макрос, дописав выражение:

    Range("C3").Select
    ActiveCell.FormulaR1C1 = "11"

  5. Выражение ActiveCell.FormulaR1C1 = "=R[-3]C+R[-2]C+R[-1]C" заменим на ActiveCell.FormulaR1C1 = "= R[-4]C+R[-3]C+R[-2]C+R[-1]C".
  6. Закрываем редактор и запускаем макрос. Как видим, вследствие введенных нами изменений была добавлена дополнительная ячейка с данными. Она также была включена в расчет общей суммы.
  7. В случае если макрос слишком большой, его выполнение может занять значительное время, но внесением ручного изменения в код мы можем ускорить процесс. Добавляем команду Application.ScreenUpdating = False. Она позволит сохранить вычислительные мощности, а значит, ускорить работу. Это достигается путем отказа от обновления экрана во время выполнения вычислительных действий. Чтобы возобновить обновление после выполнения макроса, в его конце пишем команду Application.ScreenUpdating = True.
  8. Добавим также команду Application.Calculation = xlCalculationManual в начало кода, а в его конец дописываем Application.Calculation = xlCalculationAutomatic. Этим мы сначала отключаем автоматический пересчет результата после каждого изменения ячеек, а в конце макроса – включаем. Таким образом, Excel подсчитает результат только один раз, а не будет его постоянно пересчитывать, чем сэкономит время.

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

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

  1. Кнопка в панели инструментов в MS Excel 2003 и более старше. Вам нужно в меню «Сервис» в пункте «Настройки» перейти на доступную вкладку «Команды» и в окне «Категории» выбрать команду «Настраиваемая кнопка» обозначена жёлтым колобком или смайликом, кому как понятней или удобней. Вытащите эту кнопку на свою панель задач и, нажав правую кнопку мыши по кнопке, вызовите ее контекстное меню, в котором вы сможете отредактировать под свои задачи кнопку, указав для нее новую иконку, имя и назначив нужный макрос.
  2. Кнопка в панели вашего быстрого доступа в MS Excel 2007 и более новее. Вам нужно клацнуть правой кнопкой мышки на панели быстрого доступа, которое находится в верхнем левом углу окна MS Excel и в открывшемся контекстном меню выбираете пункт «Настройка панели быстрого доступа». В диалоговом окне настройки вы выбираете категорию «Макросы» и с помощью кнопки «Добавить» вы переносите выбранный со списка макрос в другую половинку окна для дальнейшего закрепления этой команды на вашей панели быстрого доступа.

Создание графической кнопки на листе Excel

Данный способ доступен для любой из версий MS Excel и заключается он в том, что мы вынесем кнопку прямо на наш рабочий лист как графический объект. Для этого вам нужно:

  • В MS Excel 2003 и более старше переходите в меню «Вид», выбираете «Панель инструментов» и нажимаете кнопку «Формы».
  • В MS Excel 2007 и более новее вам нужно на вкладке «Разработчик» открыть выпадающее меню «Вставить» и выбрать объект «Кнопка».

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

Чтобы записать макрос, следует:

  1. Войти во вкладку «разработчик».
  2. Выбрать запись макроса.
  3. Выбрать имя макроса (в имени нельзя использовать пробелы и дефисы);
  4. Можно выбрать сочетание клавиш, при нажатии которых будет начинаться запись макроса;
  5. Выбрать место сохранения:

— при сохранении в «Эта книга» макрос будет работать только в текущем документе;

— при сохранении в «Личная книга» макрос будет работать во всех документах на Вашем компьютере.

  1. Можно добавить описание макроса, оно поможет Вам вспомнить, какие действия совершает макрос.
  2. Нажать «Ок».
  3. Если вы не указали сочетание клавиш, запись начнется сразу после нажатия кнопки «Ок».
  4. Когда идет запись, Вы должны совершать требуемую последовательность действий.
  5. Когда закончите, нажимайте кнопку остановить запись.

Записанные макросы отображаются в книге макросов.

Чтобы их посмотреть следует нажать кнопку «макросы». В появившемся окне появится список макросов. Выберете нужный макрос и нажмите «Выполнить».

Макросы, находящиеся в книге можно редактировать. Для этого нужно выбрать макрос и нажать кнопку «Изменить». При нажатии на кнопку «Изменить» откроется редактор макросов с записанным на языке VBA скриптом.

Отображение вкладки “Разработчик” в ленте меню

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

  1. Щелкните правой кнопкой мыши по любой из существующих вкладок на ленте и нажмите «Настроить ленту». Он откроет диалоговое окно «Параметры Excel».
  2. В диалоговом окне «Параметры Excel» у вас будут параметры «Настроить ленту». Справа на панели «Основные вкладки» установите флажок «Разработчик».
  3. Нажмите «ОК».

В результате на ленте меню появится вкладка “Разработчик”

Абсолютная и относительная запись макроса

Вы уже знаете про абсолютные и относительные ссылки в Excel? Если вы используете абсолютную ссылку для записи макроса, код VBA всегда будет ссылаться на те же ячейки, которые вы использовали. Например, если вы выберете ячейку A2 и введете текст “Excel”, то каждый раз – независимо от того, где вы находитесь на листе и независимо от того, какая ячейка выбрана, ваш код будет вводить текст “Excel” в ячейку A2.

Если вы используете параметр относительной ссылки для записи макроса, VBA не будет привязываться к конкретному адресу ячейки. В этом случае программа будет “двигаться” относительно активной ячейки. Например, предположим, что вы уже выбрали ячейку A1, и вы начинаете запись макроса в режиме относительной ссылки. Теперь вы выбираете ячейку A2, вводите текст Excel и нажмите клавишу Enter. Теперь, если вы запустите этот макрос, он не вернется в ячейку A2, вместо этого он будет перемещаться относительно активной ячейки. Например, если выбрана ячейка B3, она переместится на B4, запишет текст “Excel” и затем перейдет к ячейке K5.

Теперь давайте запишем макрос в режиме относительных ссылок:

  1. Выберите ячейку A1.
  2. Перейдите на вкладку “Разработчик”.
  3. В группе “Код” нажмите кнопку “Относительные ссылки”. Он будет подсвечиваться, указывая, что он включен.
  4. Нажмите кнопку “Запись макроса”.
  5. В диалоговом окне “Запись макроса” введите имя для своего макроса. Например, имя “ОтносительныеСсылки”.
  6. В опции “Сохранить в” выберите “Эта книга”.
  7. Нажмите “ОК”.
  8. Выберите ячейку A2.
  9. Введите текст “Excel” (или другой как вам нравится).
  10. Нажмите клавишу Enter. Курсор переместиться в ячейку A3.
  11. Нажмите кнопку “Остановить запись” на вкладке “Разработчик”.

Макрос в режиме относительных ссылок будет сохранен.

Теперь сделайте следующее.

  1. Выберите любую ячейку (кроме A1).
  2. Перейдите на вкладку “Разработчик”.
  3. В группе “Код” нажмите кнопку “Макросы”.
  4. В диалоговом окне “Макрос” кликните на сохраненный макрос “ОтносительныеСсылки”.
  5. Нажмите кнопку “Выполнить”.

Как вы заметите, макрос записал текст “Excel” не в ячейки A2. Это произошло, потому что вы записали макрос в режиме относительной ссылки. Таким образом, курсор перемещается относительно активной ячейки. Например, если вы сделаете это, когда выбрана ячейка B3, она войдет в текст Excel – ячейка B4 и в конечном итоге выберет ячейку B5.

Вот код, который записал макрорекодер:

 Sub ОтносительныеСсылки() ' ' ОтносительныеСсылки Макрос ' ' ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "Excel" ActiveCell.Offset(1, 0).Range("A1").Select End Sub 

Обратите внимание, что в коде нет ссылок на ячейки B3 или B4. Макрос использует Activecell для ссылки на текущую ячейку и смещение относительно этой ячейки.

Не обращайте внимание на часть кода Range(«A1»). Это один из тех случаев, когда макрорекодер добавляет ненужный код, который не имеет никакой цели и может быть удален. Без него код будет работать отлично.

Расширение файлов Excel, которые содержат макросы

Когда вы записываете макрос или вручную записываете код VBA в Excel, вам необходимо сохранить файл с расширением файла с поддержкой макросов (.xlsm).

До Excel 2007 был достаточен один формат файла – .xls. Но с 2007 года .xlsx был представлен как стандартное расширение файла. Файлы, сохраненные как .xlsx, не могут содержать в себе макрос. Поэтому, если у вас есть файл с расширением .xlsx, и вы записываете / записываете макрос и сохраняете его, он будет предупреждать вас о сохранении его в формате с поддержкой макросов и покажет вам следующее диалоговое окно:

Если вы выберете “Нет”, Excel сохранить файл в формате с поддержкой макросов. Но если вы нажмете “Да”, Excel автоматически удалит весь код из вашей книги и сохранит файл как книгу в формате .xlsx. Поэтому, если в вашей книге есть макрос, вам нужно сохранить его в формате .xlsm, чтобы сохранить этот макрос.

Что нельзя сделать с помощью макрорекодера?

Макро-рекордер отлично подходит для вас в Excel и записывает ваши точные шаги, но может вам не подойти, когда вам нужно сделать что-то большее.

  • Вы не можете выполнить код без выбора объекта. Например, если вы хотите, чтобы макрос перешел на следующий рабочий лист и выделил все заполненные ячейки в столбце A, не выходя из текущей рабочей таблицы, макрорекодер не сможет этого сделать. В таких случаях вам нужно вручную редактировать код.
  • Вы не можете создать пользовательскую функцию с помощью макрорекордера. С помощью VBA вы можете создавать пользовательские функции, которые можно использовать на рабочем листе в качестве обычных функций.
  • Вы не можете создавать циклы с помощью макрорекордера. Но можете записать одно действие, а цикл добавить вручную в редакторе кода.
  • Вы не можете анализировать условия: вы можете проверить условия в коде с помощью макрорекордера. Если вы пишете код VBA вручную, вы можете использовать операторы IF Then Else для анализа условия и запуска кода, если true (или другой код, если false).

Редактор Visual Basic

В Excel есть встроенный редактор Visual Basic, который хранит код макроса и взаимодействует с книгой Excel. Редактор Visual Basic выделяет ошибки в синтаксисе языка программирования и предоставляет инструменты отладки для отслеживания работы и обнаружения ошибок в коде, помогая таким образом разработчику при написании кода.

Запускаем выполнение макроса

Чтобы проверить работу записанного макроса, нужно сделать следующее:

  1. В той же вкладке (“Разработчик”) и группе “Код” нажимаем кнопку “Макросы” (также можно воспользоваться горячими клавишами Alt+F8).
  2. В отобразившемся окошке выбираем наш макрос и жмем по команде “Выполнить”.Примечание: Есть более простой вариант запустить выполнение макроса – воспользоваться сочетанием клавиш, которое мы задали при создании макроса.
  3. Результатом проверки будет повторение ранее выполненных (записанных) действий.

Корректируем макрос

Созданный макрос можно изменить. Самая распространенная причина, которая приводит к такой необходимости – сделанные при записи ошибки. Вот как можно отредактировать макрос:

  1. Нажимаем кнопку “Макросы” (или комбинацию Ctrl+F8).
  2. В появившемся окошке выбираем наш макрос и щелкаем “Изменить”.
  3. На экране отобразится окно редактора “Microsoft Visual Basic”, в котором мы можем внести правки. Структура каждого макроса следующая:
    • открывается с команды “Sub”, закрывается – “End Sub”;
    • после “Sub” отображается имя макроса;
    • далее указано описание (если оно есть) и назначенная комбинация клавиш;
    • команда “Range(“…”).Select” возвращает номер ячейки. К примеру, “Range(“B2″).Select” отбирает ячейку B2.
    • В строке “ActiveCell.FormulaR1C1” указывается значение ячейки или действие в формуле.
  4. Давайте попробуем скорректировать макрос, а именно, добавить в него ячейку B4 со значением 3. В код макроса нужно добавить следующие строки:
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "3"
  5. Для результирующей ячейки D2, соответственно, тоже нужно изменить начальное выражение на следующее:
    ActiveCell.FormulaR1C1 = "=RC[-2]*R[1]C[-2]*R[2]C[-2]".Примечание: Обратите внимание, что адреса ячеек в данной строке (ActiveCell.FormulaR1C1) пишутся в стиле R1C1.
  6. Когда все готово, редактор можно закрывать (просто щелкаем на крестик в правом верхнем углу окна).
  7. Запускаем выполнение измененного макроса, после чего можем заметить, что в таблице появилась новая заполненная ячейка (B4 со значением “3”), а также, пересчитан результат с учетом измененной формулы.
  8. Если мы имеем дело с большим макросом, на выполнение которого может потребоваться немало времени, ручное редактирование изменений поможет быстрее справиться с задачей.
    • Добавив в конце команду Application.ScreenUpdating = False мы можем ускорить работу, так как во время выполнения макроса, изменения на экране отображаться не будут.
    • Если потребуется снова вернуть отображение на экране, пишем команду: Application.ScreenUpdating = True.
  9. Чтобы не нагружать программу пересчетом после каждого внесенного изменения, в самом начале пишем команду Application.Calculation = xlCalculationManual, а в конце – Application.Calculation = xlCalculationAutomatic. Теперь вычисление будет выполняться только один раз.

Источники

  • https://lumpics.ru/how-to-create-a-macro-in-excel/
  • https://MicroExcel.ru/sozdanie-makrosov/
  • http://topexcel.ru/kak-sozdat-makros-v-excel/
  • https://exceltable.com/vba-macros/kak-napisat-makros
  • https://office-guru.ru/excel/samouchitel-po-rabote-s-makrosami-v-excel-449.html
  • http://RuExcel.ru/simple-macros/
  • https://micro-solution.ru/excel/vba/first-macros

Понравилась статья? Поделить с друзьями:
  • Текст через запятую разделить по столбцам в excel
  • Текстовые знаки в excel
  • Текст через запятую в столбец excel
  • Текстовые задачи с помощью excel
  • Текст цифры месяце excel