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

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

' 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_SelectionChange(ByVal Target As Range)

Application.OnKey "{~}", "StartEnter"

End Sub

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

Sub StartEnter()

MsgBox ("sadfsdfsf")

End Sub

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

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

Sub Worksheet_Change(ByVal Target As Excel.Range)

Call UpdateToolbar

End Sub

 

Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

Call UpdateToolbar

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 UpdateToolbar

End Sub

 

Sub UpdateToolbar()

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

On Error Resume Next

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

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

ActiveCell.NumberFormat

End Sub

 

Sub ChangeNumFormat()

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

Application.Dialogs(xlDialogFormatNumber).Show

Call UpdateToolbar

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

 

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

Sub FileSearch()

Dim strFileName As String

Dim strFolder As String

Dim strFullPath As String

 

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

strFolder = InputBox("Определите папку:")

If strFolder = "" Then Exit Sub

' Задание имени файла для поиска

strFileName = Application.InputBox("Введите имя файла:")

If strFileName = "" Then Exit Sub

' При необходимости дополняем имя папки "\"

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

 

' Полный путь файла

strFullPath = strFolder & strFileName

 

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

MsgBox "Использование команды VBA..." & vbCrLf & vbCrLf & _

dhSearchVBA(strFullPath), vbInformation, strFullPath

' Вывод окна с отчетом о поиске средствами объекта FileSearch

MsgBox "Использование объекта FileSearch..." & vbCrLf & _

vbCrLf & dhSearchFileSearch(strFolder, strFileName), vbInformation, _

strFullPath

' Вывод окна с отчетом о поиске средствами объекта _

FileSystemObject

MsgBox "Использование объекта FileSystemObject..." & vbCrLf & _

vbCrLf & dhSearchFileSystemObject(strFullPath), vbInformation, _

strFullPath

End Sub

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

 

Function dhSearchVBA(varFullPath As Variant) As Boolean

' Использование команды VBA

dhSearchVBA = Dir(varFullPath) <> ""

End Function

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

 

Function dhSearchFileSearch(varFolder As Variant, varFileName _

 As Variant) As Boolean

' Использование объекта FileSearch

With Application.FileSearch

' Создание нового поиска

.NewSearch

' Имя для поиска

    .FileName = varFileName

' Папка поиска

.LookIn = varFolder

' Собственно поиск

.Execute

dhSearchFileSearch =.FoundFiles.Count <> 0

End With

End Function

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

 

Function dhSearchFileSystemObject(varFullPath As Variant) As Boolean

Dim objFSObject As Object

' Использование объекта FileSystemObject

Set objFSObject = CreateObject("Scripting.FileSystemObject")

dhSearchFileSystemObject = objFSObject.FileExists(varFullPath)

End Function

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

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

Экспорт данных в txt

Sub ExportAsText()

Dim lngRow As Long

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 Long       ' Номер текущей строки

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

Экспорт данных в html

Sub ExportAsHtmlFile()

Dim strStyle As String ' Параметры стиля отображения ячейки

Dim strAlign As String ' Параметры выравнивания ячейки

Dim strOut As String  ' Выходная строка с HTML-кодом

Dim cell As Object    ' Обрабатываемая ячейка

Dim strCellText As String ' Текст обрабатываемой ячейки

Dim lngRow As Long    ' Номер строки обрабатываемой ячейки

Dim lngLastRow As Long ' Номер строки предыдущей ячейки

Dim strTemp As String

Dim strFileName As String ' Имя файла для сохранения HTML-кода

Dim i As Long

 

' Запрос у пользователя имени файла для сохранения

strFileName = Application.GetSaveAsFilename(_

InitialFileName:="Primer.htm", _

fileFilter:="HTML 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>"

 

' Сохранение HTML-кода в файл

Open strFileName For Output As 1

Print #1, strOut

Close 1

 

' Вывод окна с информационным сообщением о результатах работы

MsgBox Selection.Count & " ячеек экспортировано в файл " & _

strFileName

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, UpdateLinks:=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()

 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 Long

' Объявление API-функции для преобразования данных, возвращаемых _

 функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

 Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _

 pszPath As String) As Long

 

' Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

hwndOwner As Long ' Родительское окно (для диалога)

pidlRoot As Long ' Корневая папка для просмотра

strDisplayName As String

strTitle As String ' Заголовок окна

ulFlags As Long  ' Флаги для окна

' Следующие три параметра в VBA не используются

lpfn As Long

lParam As Long

iImage As Long

End Type

 

Sub BrowseFolder()

Dim strPath As String ' Папка, список файлов которой выводится

Dim strFile As String

Dim intRow As Long ' Текущая строка таблицы

 

' Выбор папки

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 Long

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 Long

' Объявление API-функции для преобразования данных, возвращаемых _

 функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

 Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _

 pszPath As String) As Long

 

' Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

hwndOwner As Long ' Родительское окно (для диалога)

pidlRoot As Long ' Корневая папка для просмотра

strDisplayName As String

strTitle As String ' Заголовок окна

ulFlags As Long  ' Флаги для окна

' Следующие три параметра в VBA не используются

lpfn As Long

lParam As Long

iImage As Long

End Type

 

Sub BrowseFolder1()

Dim strPath As String ' Папка, список файлов которой выводится

Dim strFile As String

Dim intRow As Long ' Текущая строка таблицы

 

' Выбор папки

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 Long

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 ‘(expression.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 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").Move, after:=Sheets("Лист3")

 End With

End Sub

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

 

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

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

Function dhSheetExist(strSheetName As String) As Boolean

Dim objSheet As Object

 

On Error GoTo HandleError ' При ошибке перейти на HandleError

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

objSheet = ActiveWorkbook.Sheets(strSheetName)

' Ошибки не возникло - лист существует

dhSheetExist = True

Exit Function

 

HandleError:

' При попытке получить доступ к листу с заданным именем _

возникла ошибка, значит, такого листа не существует

dhSheetExist = False

End Function

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

L = 0

For Each Sheet In Worksheets

If Sheet.Name = "List12" Then

L = 1

MsgBox "List12 совпадает с расчетным листом. Переименуйте свой List12 на какое нибудь другое имя!"

End If

Next

If L = 0 Then

Worksheets.Add.Name = "List12"

Worksheets(1).Visible = True

Worksheets("List12").Visible = True

Worksheets("List12").Activate

End If

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

Sub Test()

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

 .Sheets.Item("Лист5").Visible = False

End With

End Sub

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

Sub CountOfCells()

MsgBox (Range("A1:A20, D1:D20").Count)

End Sub

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

Sub SetCellData()

' Заполнение значениями ячеек А3 и В4

Range("A3") = "Данные для ячейки A3"

Range("B4") = "Данные для ячейки B4"

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

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

переменная.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 Long

Dim lngCell As Long

 

' Пойдем по диапазону с конца (тогда первая попавшаяся _

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

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 Long

Dim iColumn As Long

 

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.Insert Shift:=xlDown

Cells(2, 2).FormulaR1C1 = "=IF((RC[-1]=R[-1]C[-1])+(RC[-1]=R[1]C[-1]),1,0)"

Range("b2").Select

Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)), Type:=xlFillDefault

Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)).Copy

Cells(2, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

For Each ar In r.Cells

If ar.Value <> Empty Then

   If WorksheetFunction.VLookup(ar.Value, Range(Cells(2, 1), Cells(r.Count + 1, 2)), 2, 0) Then

       ar.Interior.ColorIndex = 3

   End If

End If

Next

Application.DisplayAlerts = False

ActiveSheet.Delete

Sheets(nm).Select

ActiveCell.Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

'prog = r_prog

End Sub

Sub uncolor()

Selection.Interior.ColorIndex = xlNone

End Sub

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

Dim r As Range

Dim foundCell As Range

 

Set r = ActiveSheet.Range("A1:A6")

Set foundCell = r.Find("Ichiro", LookIn:=xlValues)

If Not foundCell Is Nothing Then

foundCell.Select

Else

MsgBox "String not found."

End If

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

Sub findtekst()

Dim c As Range

Set c = Range("c3:c98").Find("*ГКИ*",,, xlWhole)

If Not c Is Nothing Then c.Select

MsgBox (c)

End Sub

Также для финда по xlWhole вариации:

"*a" - заканчивается на a

"?a*" - 2-я буква a

"??a*" - 3-я буква а

"a?" - начинается на a и содержит ещё 1 любую букву

"a?*" - 2+ буквы минимум и начинается на a (например a1, a10, a12, a55, a55dd56 всё посчитается)

"*слово*" - находит слова сод