|
|||||||
Время создания: 16.03.2019 23:43
Текстовые метки: vba, сборник
Раздел: !Закладки - VBA
Запись: xintrea/mytetra_db_adgaver_new/master/base/1514388018pfti4b70ex/text.html на raw.githubusercontent.com
|
|||||||
|
|
|||||||
|
Представляю Вашему вниманию огромный сборник макросов и функций, все макросы сгруппированы по главам, для удобства добавил оглавление с гиперссылками.
К сообщению приложен файл: macros.rar (83Kb) Запуск макроса с поиском ячейки Запуск макроса при открытии книги Запуск макроса при вводе в ячейку «2» Запуск макроса при нажатии «Ентер» Добавить в панель свою вкладку «Надстройки» (Формат ячейки) ГЛАВА 2. РАБОТА С ФАЙЛАМИ (Т.Е.ОБМЕН ДАННЫМИ С ТХТ, RTF, XLS И Т.Д.) Проверка наличия файла по указанному пути_1 Проверка наличия файла по указанному пути_2 Проверка наличия файла по указанному пути_3 Произвольный текст в строке состояния Восстановление строки состояния Бегущая строка в строке состояния Быстрое изменение заголовка окна Быстрое изменение заголовка окна_2 Изменение заголовка окна (со скрытием названия файла) Возврат к первоначальному заголовку Запись и чтение текстового файла Обработка нескольких текстовых файлов Определение конца строки текстового файла Копирование из текстового файла в эксель Копирование содержимого в текстовый файл_1 Копирование содержимого в текстовый файл_2 Создание резервных копий ценных файлов Подсчет количества открытий файла Вывод пути к файлу в активную ячейку Копирование содержимого файла RTF в эксель Копирование данных из закрытой книги Извлечение данных из закрытого файла Создание текстового файла и ввод текста в файл Создание текстового файла и ввод текста (определение конца файла) Создание документов Word на основе таблицы Excel Команды создания и удаления каталогов Посмотреть все файлы в каталоге_1 Посмотреть все файлы в каталоге_2 Посмотреть все файлы в каталоге_3 ГЛАВА 3. РАБОЧАЯ ОБЛАСТЬ MICROSOFT EXCEL Открытие книги (или текстовых файлов) Открытие книги и добавление в ячейку А1 текста Закрытие рабочей книги только при выполнении условия Сохранение рабочей книги с именем, представляющим собой текущую дату Быстрое размножение рабочей книги Поиск максимального значения на всех листах книги Проверка наличия защиты рабочего листа Копирование листа в новую книгу (создается) Перемещение нескольких листов в новую книгу Вставка колонтитула с именем книги, листа и текущей датой Вывод количества листов в активной книге Вывод количества листов в активной книге в виде гиперссылок Вывод имен активных листов по очереди Вывод имени и номеров листов текущей книги Сколько страниц на всех листах? Копирование строк на другой лист Копирование столбцов на другой лист Подсчет количества ячеек, содержащих указанные значения_1 Подсчет количества ячеек в диапазоне, содержащих указанные значения_2 Подсчет количества видимых ячеек в диапазоне Определение количества ячеек в диапазоне и суммы их значений Автоматический пересчет данных таблицы при изменении ее значений Ввод данных с использованием формул Ввод текстоввых данных в ячейки Вывод в ячейки названия книги, листа и количества листов Удаление используемых скрытых строк или строк с нулевой высотой Выделение диапазона над текущей ячейкой Выделение диапазона над текущей ячейкой_2 Выделение отрицательных значений Выделение диапазона и использование абсолютных адресов Выделение ячеек через интервал_2 Поиск ближайшей пустой ячейки столбца Поиск значения с отображением результата в отдельном окне Поиск с выделением найденных данных_1 Поиск с выделением найденных данных_2 Поиск последней непустой ячейки диапазона Поиск последней непустой ячейки столбца Поиск последней непустой ячейки строки Поиск ячейки синего цвета в диапазоне Поиск наличия значения в столбце Поиск приближенного значения в диапазоне Поиск начала и окончания диапазона, содержащего данные Автоматическая замена значений Быстрое заполнение диапазона (массив) Заполнение через интервал(массив) Заполнение указанного диапазона(массив) Расчет суммы первых значений диапазона Размещение в ячейке электронных часов Получение информации о выделенном диапазоне Создание изменяемого списка (таблица) Умножение выделенного диапазона на 2 Одновременное умножение всех данных диапазона Суммирование данных только видимых ячеек Сумма ячеек с числовыми значениями При суммировании — курсор внутри диапазона Начисление процентов в зависимости от суммы_1 Начисление процентов в зависимости от суммы_2 Начисление процентов в зависимости от суммы_3 Сводный пример расчета комиссионного вознаграждения Объединение данных диапазона_2 Узнать максимальную колонку или строку. Ограничение возможных значений диапазона Тестирование скорости чтения и записи диапазонов Открыть MsgBox при выборе ячейки Скрытие строки по имени ячейки Скрытие нескольких строк по адресам ячеек Скрытие столбца по имени ячейки Скрытие нескольких столбцов по адресам ячеек ГЛАВА 4. РАБОТА С ПРИМЕЧАНИЯМИ Вывод на экран всех примечаний рабочего листа Функция извлечения комментария Список примечаний защищенных листов Перечень примечаний в отдельном списке_1 Перечень примечаний в отдельном списке_2 Перечень примечаний в отдельном списке_3 Подсчет количества примечаний_1 Выделение ячеек с примечаниями Добавление примечаний в диапазон по условию Перенос комментария в ячейку и обратно Перенос значений из ячейки в комментарий_1 Перенос значений из ячейки в комментарий_2 ГЛАВА 5 . ПОЛЬЗОВАТЕЛЬСКИЕ ВКЛАДКИ НА ЛЕНТЕ Дополнение панели инструментов Добавление кнопки на панель инструментов Вызов предварительного просмотра Создание пользовательского меню (вариант 1) Создание пользовательского меню (вариант 2) Создание пользовательского меню (вариант 3) Создание пользовательского меню (вариант 4) Создание пользовательского меню (вариант 5) Создание списка пунктов главного меню Excel Создание списка пунктов контекстных меню Отображение панели инструментов при определенном условии Скрытие и отображение панелей инструментов Создать подсказку к моим кнопкам Создание меню на основе данных рабочего листа Добавление команды в меню Сервис Мультфильм с помощником в главной роли Дополнение помощника текстом, заголовком, кнопкой и значком Использование помощника для выбора цвета заливки Функция INPUTBOX (через ввод значения) Настройка ввода данных в диалоговом окне Открытие диалогового окна (“Открыть файл”)_1 ГЛАВА 7.ФОРМАТИРОВАНИЕ ТЕКСТА. ТАБЛИЦЫ. ГРАНИЦЫ И ЗАЛИВКА. Вывод списка доступных шрифтов Прописная буква только в начале текста Подсчет количества повторов искомого текста Выделение из текста произвольного элемента Отображение текста «задом наперед» Запуск таблицы символов из Excel ГЛАВА 8 ИНФОРМАЦИЯ О ПОЛЬЗОВАТЕЛЕ, КОМПЬЮТЕРЕ, ПРИНТЕРЕ И Т.Д. Получение информации об используемом принтере Просмотр информации о дисках компьютера Построение диаграммы с помощью макроса Сохранение диаграммы в отдельном файле Построение и удаление диаграммы нажатием одной кнопки Применение случайной цветовой палитры Построение диаграммы на основе данных нескольких рабочих листов Создание подписей к данным диаграммы Программа для составления кроссвордов Расчет на основании ячеек определенного цвета ГЛАВА 11. ДРУГИЕ ФУНКЦИИ И МАКРОСЫ Расчет среднего арифметического значения Расчет средневзвешенного значения Преобразование номера месяца в его название Использование относительных ссылок Преобразование таблицы Excel в HТМL-формат Случайные числа — на основании диапазона Применение функции без ввода ее в ячейку Включение автофильтра с помощью макроса Склонение фамилии, имени и отчества Запуск макроса с поиском ячейки ' 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.200\c\", 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
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
Function dhSearchVBA(varFullPath As Variant) As Boolean ' Использование команды VBA dhSearchVBA = Dir(varFullPath) <> "" End Function
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
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 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:\contacts\zakaz\[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:\windows\inf\*.*") 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
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 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 Selection.SpecialCells(xlCellTypeBlanks).Select Selection.Delete Shift:=xlUp 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 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 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 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
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 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
Функция 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 ' Позиция |
