VBA: простые макросы для Excel

Введение в написание макросов на VBA есть в этой заметке, там же показано, с чего начать, как их выполнять и как сохранить рабочую книгу Excel с макросами (можно и документ Word, но Excel явно удобней для обращения с данными).

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

1. Как ввести 2 аргумента и вычислить, а затем вывести значение функции от этих двух аргументов?

Листинг показан ниже. Обратите внимание, что при вычислении максимума мы пользуемся функцией Excel Max (вызывая её, как метод объекта Application):

Sub Task_1()
 X! = Val(InputBox("Type X", "Input X", 0))
 Y! = Val(InputBox("Type Y", "Input Y", 0))
 Z! = Application.Max(X, Y) + X ^ 2 - Y ^ 2
 MsgBox ("Z(" + Str(X) + "," + Str(Y) + ")=" + _
  Str(Round(Z, 3)))
End Sub

2. Как ограничить допустимые значения вводимых аргументов? Как уменьшить количество знаков в дробной части числа при выводе?

Проще всего - указав тип данных нужной величины при её создании (например, A! означает, что значение A - вещественное, A% - что целое) и ограничив диапазон допустимых условий с помощью дополнительных проверок оператором If.

Ну а округлить легче всего с помощью стандартной функции Round.

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

Sub Task_2()
 'Из h = g*t^2 /2 следует t = корень(2h / g)
 H! = Val(InputBox("Введите высоту", "", 0))
 If H < 0 Then
  H = 0
 End If
 G! = 9.81
 T! = Sqr(2 * H / G)
 MsgBox ("Время(" + Str(H) + ")=" + _
  Str(Round(T, 3)))
End Sub

3. Как вычислить в цикле с известным количеством шагов произведение или сумму?

Sub Task_2_1()
 'Даны действительное число а, натуральное число n.
 'Вычислить а(а + 1)...(a + n - 1)
 A! = Val(InputBox("A=", "", 0))  '! - вещественное
 N% = Val(InputBox("N=", "", 10)) '% - целое
 P! = 1
 For I = 0 To N - 1 Step 1
  P! = P! * (A + I)
 Next
 MsgBox ("P=" + Str(Round(P, 2)))
End Sub

4. Как сформировать одномерный вектор по правилу?

Sub Task_2_2()
 'Даны действительные числа a_1,...,a_n, b_1,...,b_n
 'Вычислить (a_1 + b_n)(a_2 + b_n-1)... (a_n + b_1)
 Const N = 5
 Dim A(1 To N), B(1 To N), C(1 To N) As Double: S = ""
 For I = 1 To N
  A(I) = I: B(N + 1 - I) = I
  C(I) = A(I) + B(N + 1 - I)
  S = S + Str(C(I)) + " "
 Next
 MsgBox "S=" + S
End Sub

5. Как сформировать двумерный вектор (матрицу) по правилу? Как вывести матрицу на рабочий лист Excel?

Код для вывода элементов матрицы на лист может быть таким, как в этом примере, если явно известны нужные номера строки R и столбца C.

Sub Task_2_3() 'A(I,J) = 1/ (I+J)
 Const N = 5
 Dim A(1 To N, 1 To N) As Double
 For I = 1 To N Step 1
  For J = 1 To N Step 1
   A(I, J) = Round(1 / (I + J), 2)
   Sheets(1).Cells(I, J).Value = A(I, J)
  Next
 Next
End Sub

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

Sub Task_2_3_1()
 Const N = 5
 Dim A(1 To N, 1 To N) As Integer
 R = 1: C = 0: Dr = 1: It = 0
 For K = 1 To N * N Step 1
1:
   If Dr = 1 Then
    If C < N - It Then
     C = C + 1
    Else
     Dr = 2: GoTo 1
    End If
   ElseIf Dr = 2 Then
    If R < N - It Then
     R = R + 1
    Else
     Dr = 3: GoTo 1
    End If
   ElseIf Dr = 3 Then
    If C > 1 + It Then
     C = C - 1
    Else
     Dr = 4: It = It + 1: GoTo 1
    End If
   ElseIf Dr = 4 Then
    If R > 1 + It Then
     R = R - 1
    Else
     Dr = 1: GoTo 1
    End If
   End If
   A(R, C) = K
   Sheets(1).Cells(R, C).Value = A(R, C)
 Next
End Sub

6. Как узнать, равна ли дробная часть числа нулю?

Sub Task_2_0()
 A! = Val(InputBox("A=", "", 0))
 If Round(A, 0) = A Then
  MsgBox "Yes"
 Else
  MsgBox "No"
 End If
End Sub

7. Как получить все числа вида XXYY и т.п., где "X", "Y" - произвольные различные между собой цифры?

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

Sub Task_2_5() 'Все числа вида XXYY выводим в столбец "B"
 I = 1
 For X = 0 To 9
  For Y = 0 To 9
   Range("B" & I).Value = X * 1000 + X * 100 + Y * 10 + Y
   I = I + 1
  Next
 Next
End Sub

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

8. Как сделать цикл по степеням двойки (или другого числа)?

Sub Task_2_6() 'Цикл по степеням двойки, не превышающим D
 N = 1: I = 1: D = 1000
 Do While N <= D
  Range("B" & I).Value = N
  N = 2 ^ I
  I = I + 1
 Loop
End Sub

9. Как найти сумму цифр числа?

Sub Digit() 'Сумма цифр числа
 V = InputBox("N=", "", 1234)
 If IsNumeric(V) = False Then
  MsgBox "Введите число!": Exit Sub
 End If
 If CLng(V) <> V Then
  V = CLng(V)
  MsgBox "Число исправлено на целое " & V
 End If
 N = Str(V): L = Len(N): D = 0
 For I = 1 To L - 1
  D = Val(Mid(N, I + 1, 1)) 'Извлечение I-ой цифры
  S = S + D
  'MsgBox "Digit " & I & "=" & Mid(N, I + 1, 1)
 Next I
 MsgBox "Сумма цифр = " & S
End Sub

10. Как из макроса VBA с помощью стандартных окон диалога ввести динамический массив с проверкой допустимости введённой размерности и элементов?

Такой ввод будет несколько "назойлив", но вот законченный пример, обратите внимание на комментарии в исходнике.

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

Sub GetArray()
 Dim A() As Double
 Dim N
10
 Do 'Ввод размерности с контролем
  N = InputBox("N=", "Type the size of array", 5)
  If Not IsNumeric(N) Then
   GoTo 10
  End If
  N = Val(N)
  If Int(N) <> N Or N < 1 Then
   ' можно было добавить ещё верхнюю границу, например, Or N > 100
   GoTo 10
  End If
  Exit Do
 Loop
 ReDim A(1 To N)
    
 Dim Result As String 'просто показать строкой, что получилось
    
 Dim V
 For I = 1 To N 'Ввод элементов массива (можно вещественных)
  Do
   V = InputBox("A(" & Str(I) & ")=", "Item " & Str(I))
  Loop While Not IsNumeric(V)
  'Вещественное число вводится в зависимости от локали, например, по-русски 2,34 а не 2.34
  A(I) = CDbl(V) 'Val здесь не поможет!
  Result = Result + Str(A(I)) + " "
 Next
 MsgBox (Result)
End Sub

11. Как узнать, ввёл ли пользователь что-нибудь в окно InputBox или нажал "Отмену"?

Проще всего - вот так.

Sub GetButton()
 Dim Result As String
 Result = InputBox("Type Anytnig...", "Input", "")
 If StrPtr(Result) = 0 Then
   MsgBox ("User canceled!")
 ElseIf Result = vbNullString Then
   MsgBox ("User didn't enter anything!")
 Else
   MsgBox ("User entered " & Result)
 End If
End Sub

12. Как сделать более простой чем в задаче 10 ввод размерности и элементов массива через окна InputBox, пусть даже максимальная размерность будет ограничена?

Ну, если очень хочется, можно так:

Sub array1()
 Const n = 10
 Dim a(1 To n) As Double
 Dim m As Integer
 Do
  m = Val(InputBox("M=", "", 5))
 Loop While Not IsNumeric(m)
 If m < 2 Or m > n Then
  m = 5
  MsgBox "Неверная размерность, исправлена на 5"
 End If
 For I = 1 To m
  a(I) = Val(InputBox("A(" & Str(I) & ")=", "Item " & Str(I)))
  MsgBox "Item=" & a(I) ' только для проверки, убрать
 Next I
 'обработка массива a из m элементов
End Sub

Причём, функция Val игнорирует локаль, то есть, при русской локали Windows надо будет при работе array1 вводить вещественное значение в виде 3.5 , а увидим его в окне MsgBox как 3,5

Вот поэтому-то ввод данных просто из ячеек рабочего листа Excel удобнее :)

13. Как отформатировать векторные или матричные данные в окне сообщения MsgBox?

Делать этого не нужно, лучше писать данные в ячейки рабочего листа Excel, как в примере 5, и форматировать уже там.

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

Но если очень хочется, то можно использовать функцию Format из VBA, они "понимает" форматы в том же виде, что и окно свойств ячеек Excel:

Sub format1()
 Const n = 5
 Dim a(1 To n, 1 To n) As Single
 Dim s As String
 Dim i, j As Integer
 s = ""
 Randomize
 For i = 1 To n
  For j = 1 To n
   a(i, j) = Rnd() * 20 - 10
   s = s & Format(a(i, j), " 0.00 ;-0.00 ")
  Next
  s = s & vbCrLf
 Next
 MsgBox s
End Sub

• заполняем вещественную матрицу размерности n x n случайными числами из интервала от -10 до 10, при каждом запуске различными (Randomize);
• перед записью в строку s форматируем элементы матрицы a(i,j) так, чтобы перед отрицательными значениями стоял знак "-", а в дробной части было всегда 2 знака. Пробелы в строке формата имеют значение;
• выводим строку с данными из матрицы в окно MsgBox в "естественном виде", то есть, с разбиением на строки и элементы.

14.05.2019, 16:19 [2774 просмотра]