Примеры макросов Excel

'Процедура Sub выполняет поиск ячейки, содержащей заданную строку
'в диапазоне ячеек A1:A100 активного листа

Sub Find_String(sFindText As String)

   Dim i As Integer 'Целое число типа Integer, используется в цикле For
   Dim iRowNumber As Integer 'Целое число типа Integer для хранения результата

   iRowNumber = 0

   'Просматривает одну за другой ячейки A1:A100 до тех пор, пока не будет найдена строка sFindText

   For i = 1 To 100

      If Cells(i, 1).Value = sFindText Then

         'Если совпадение с заданной строкой найдено
         'сохраняем номер текущей строки и выходим из цикла For
         iRowNumber = i
         Exit For

      End If
   Next i

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

   If iRowNumber = 0 Then
      MsgBox "Строка " & sFindText & " не найдена"
   Else
      MsgBox "Строка " & sFindText & " найдена в ячейке A" & iRowNumber
   End If

End Sub

'Процедура Sub выводит числа Фибоначчи, не превышающие 1000

Sub Fibonacci()

   Dim i As Integer 'Счётчик для обозначения позиции элемента в последовательности
   Dim iFib As Integer 'Хранит текущее значение последовательности
   Dim iFib_Next As Integer 'Хранит следующее значение последовательности
   Dim iStep As Integer 'Хранит размер следующего приращения

   'Инициализируем переменные i и iFib_Next
   i = 1
   iFib_Next = 0

   'Цикл Do While будет выполняться до тех пор, пока значение
   'текущего числа Фибоначчи не превысит 1000

   Do While iFib_Next < 1000

      If i = 1 Then
         'Особый случай для первого элемента последовательности
         iStep = 1
         iFib = 0
      Else
         'Сохраняем размер следующего приращения перед тем, как перезаписать
         'текущее значение последовательности
         iStep = iFib
         iFib = iFib_Next
      End If

      'Выводим текущее число Фибоначчи в столбце A активного рабочего листа
      'в строке с индексом i
      Cells(i, 1).Value = iFib

      'Вычисляем следующее число Фибоначчи и увеличиваем индекс позиции элемента на 1
      iFib_Next = iFib + iStep
      i = i + 1
   Loop

End Sub

'Процедура Sub сохраняет значения ячеек столбца A активного листа в массиве

Sub GetCellValues()

   Dim iRow As Integer 'Хранит номер текущей строки
   Dim dCellValues() As Double 'Массив для хранения значений ячеек

   iRow = 1
   ReDim dCellValues(1 To 10)

   'Цикл Do Until перебирает последовательно ячейки столбца A активного листа
   'и извлекает их значения в массив до тех пор, пока не встретится пустая ячейка

   Do Until IsEmpty(Cells(iRow, 1))

      'Проверяем, что массив dCellValues имеет достаточный размер
      'Если нет – увеличиваем размер массива на 10 при помощи ReDim
      If UBound(dCellValues) < iRow Then
         ReDim Preserve dCellValues(1 To iRow + 9)
      End If

      'Сохраняем значение текущей ячейки в массиве dCellValues
      dCellValues(iRow) = Cells(iRow, 1).Value

      iRow = iRow + 1
   Loop

End Sub

'Процедура Sub при помощи цикла считывает значения в столбце A рабочего листа Лист2,
'выполняет с каждым значением арифметические операции и записывает результат в
'столбец A активного рабочего листа (Лист1)

Sub Transfer_ColA()

   Dim i As Integer
   Dim Col As Range
   Dim dVal As Double

   'Присваиваем переменной Col столбец A рабочего листа Лист 2

   Set Col = Sheets("Лист2").Columns("A")
   i = 1

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

   Do Until IsEmpty(Col.Cells(i))

      'Выполняем арифметические операции над значением текущей ячейки

      dVal = Col.Cells(i).Value * 3 - 1

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

      Cells(i, 1) = dVal
      i = i + 1

   Loop

End Sub

'Данный код показывает окно с сообщением, если на текущем рабочем листе
'выбрана ячейка B1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   'Проверяем выбрана ли ячейка B1
   If Target.Count = 1 And Target.Row = 1 And Target.Column = 2 Then

      'Если ячейка B1 выбрана, выполняем необходимое действие
      MsgBox "Вы выбрали ячейку B1"

   End If

End Sub

'Процедура Sub присваивает аргументам Val1 и Val2 значения ячеек A1 и B1
'из рабочей книги Data.xlsx, находящейся в папке C:\Documents and Settings

Sub Set_Values(Val1 As Double, Val2 As Double)

   Dim DataWorkbook As Workbook

   On Error GoTo ErrorHandling

      'Открываем рабочую книгу с данными

      Set DataWorkbook = Workbooks.Open("C:\Documents and Settings\Data")

      'Присваиваем переменным Val1 и Val2 значения из заданной рабочей книги

      Val1 = Sheets("Лист1").Cells(1, 1)
      Val2 = Sheets("Лист1").Cells(1, 2)

      DataWorkbook.Close

   Exit Sub

ErrorHandling:

   'Если файл не найден, пользователю будет предложено поместить искомый файл
   'в нужную папку и после этого продолжить выполнение макроса

   MsgBox "Файл Data.xlsx не найден! " & _
      "Пожалуйста добавьте рабочую книгу в папку C:\Documents and Settings и нажмите OK"
   Resume

End Sub