VBA: Найти сумму и количество тех элементов массива, которые делятся на 5 и на 8 одновременно. Полученные значения вывести в одно окно сообщения

Задача:

Дан динамический массив В(n), заполненный случайными числами с помощью генератора случайных чисел (элементы массива вывести в ячейки рабочего листа).  Найти сумму и количество тех элементов массива, которые делятся на 5 и на 8 одновременно. Полученные значения вывести в одно окно сообщения.

Код:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Public Sub prog()
    Dim i As Integer
    Dim sum As Integer
    Dim count As Integer
    sum = 0
    count = 0
    n = InputBox("n=") ' Просим ввести n - размерность массива.
    ReDim B(n)
    Cells.Value = ""
    Cells.Interior.ColorIndex = -4142
    For i = 1 To n
        B(i) = Int((0 - 100 + 1) * Rnd + 100)
        If ((B(i) Mod 5 = 0) And (B(i) Mod 8 = 0)) Then
            sum = sum + B(i)
            count = count + 1
            Cells(1, i).Interior.Color = vbGreen
        End If
        Cells(1, i).Value = B(i) ' Печать в ячейку
    Next i
    MsgBox ("Сумма = " + CStr(sum) + " Количество = " + CStr(count))
End Sub
Public Sub prog()
    Dim i As Integer
    Dim sum As Integer
    Dim count As Integer
    sum = 0
    count = 0
    n = InputBox("n=") ' Просим ввести n - размерность массива.
    ReDim B(n)
    Cells.Value = ""
    Cells.Interior.ColorIndex = -4142
    For i = 1 To n
        B(i) = Int((0 - 100 + 1) * Rnd + 100)
        If ((B(i) Mod 5 = 0) And (B(i) Mod 8 = 0)) Then
            sum = sum + B(i)
            count = count + 1
            Cells(1, i).Interior.Color = vbGreen
        End If
        Cells(1, i).Value = B(i) ' Печать в ячейку
    Next i
    MsgBox ("Сумма = " + CStr(sum) + " Количество = " + CStr(count))
End Sub

Continue reading

VBA: Найти сумму и количество элементов массива, остаток от деления которых на 2 равен 3

Глупая задача…

Дан динамический массив А(n), заполненный случайными числами с помощью генератора случайных чисел (элементы массива вывести в ячейки рабочего листа). Найти сумму и количество элементов массива, остаток от деления которых на 2 равен 3. Полученные значения вывести в одно окно сообщения.

Ни одно число не будет подходить под условие задачи, но решение есть.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Public Sub sum1()
    Dim i As Integer
    Dim sum As Integer
    Dim count As Integer
    sum = 0
    count = 0
    n = InputBox("n=") ' Просим ввести n - размерность массива.
    ReDim arr(n)
    Cells.Value = ""
    Cells.Interior.ColorIndex = -4142
    For i = 1 To n
        arr(i) = Int((0 - 100 + 1) * Rnd + 100)
        If (arr(i) Mod 2 = 0) Then
            sum = sum + arr(i)
            count = count + 1
            Cells(1, i).Interior.Color = vbGreen
        End If
        Cells(1, i).Value = arr(i) ' Печать в ячейку
    Next i
    MsgBox ("Сумма = " + CStr(sum) + " Количество = " + CStr(count))
End Sub
Public Sub sum1()
    Dim i As Integer
    Dim sum As Integer
    Dim count As Integer
    sum = 0
    count = 0
    n = InputBox("n=") ' Просим ввести n - размерность массива.
    ReDim arr(n)
    Cells.Value = ""
    Cells.Interior.ColorIndex = -4142
    For i = 1 To n
        arr(i) = Int((0 - 100 + 1) * Rnd + 100)
        If (arr(i) Mod 2 = 0) Then
            sum = sum + arr(i)
            count = count + 1
            Cells(1, i).Interior.Color = vbGreen
        End If
        Cells(1, i).Value = arr(i) ' Печать в ячейку
    Next i
    MsgBox ("Сумма = " + CStr(sum) + " Количество = " + CStr(count))
End Sub

Файл Excel с этим кодом

VBA: Определить, число, больше, меньше или равно нулю

Задача:

В клетке В2 сделайте сообщение о том, какое число записано в клетку А2 – положительное, отрицательное или ноль.

Для ее решения используется простая лесенка If Else If:

Исходный код:

1
2
3
4
5
6
7
8
9
10
11
Sub Button1_Click()
     If (Cells(2, 1).Value > 0) Then
        Cells(2, 2).Value = "Больше нуля"
     Else
        If (Cells(2, 1).Value < 0) Then
            Cells(2, 2).Value = "Меньше нуля"
        Else
            Cells(2, 2).Value = "Равно нулю"
        End If
     End If
End Sub
Sub Button1_Click()
     If (Cells(2, 1).Value > 0) Then
        Cells(2, 2).Value = "Больше нуля"
     Else
        If (Cells(2, 1).Value < 0) Then
            Cells(2, 2).Value = "Меньше нуля"
        Else
            Cells(2, 2).Value = "Равно нулю"
        End If
     End If
End Sub

Пример работы программы:

Пример

Скачать документ Excel

VBA: Рассчитать величину вклада в банке по месяцам

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

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

Для входных данных будут использоваться ячейки 2,1; 2,2; 2,3.

Continue reading

VBA: Как можно получить строку до пробела? (обрезать строку до первого пробела)

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

Сделать это можно несколькими путями.

Continue reading

VBA, Раскрасить матрицу

Сделать элементы главной диагонали матрицы одним цветом, выше — другим, ниже третьим.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Public Sub glav_diag()
Dim i As Integer
Dim j As Integer
 
n = InputBox("n=")
 
For i = 1 To n
  For j = 1 To n
    If i = j Then
      Cells(i, j).Interior.Color = vbGreen
    End If
    If i < j Then
      Cells(i, j).Interior.Color = vbRed
    End If
    If i > j Then
      Cells(i, j).Interior.Color = vbBlack
    End If
  Next j
Next i
End Sub
Public Sub glav_diag()
Dim i As Integer
Dim j As Integer

n = InputBox("n=")

For i = 1 To n
  For j = 1 To n
    If i = j Then
      Cells(i, j).Interior.Color = vbGreen
    End If
    If i < j Then
      Cells(i, j).Interior.Color = vbRed
    End If
    If i > j Then
      Cells(i, j).Interior.Color = vbBlack
    End If
  Next j
Next i
End Sub

Проход по всему массиву и если i=j (главная диагональ) то зеленым, если i<j (выше) то красный, в ином случае черным. Пример:

Continue reading

Работа с матрицей в VBA

Внезапно появились лабораторные :)

Задачка такая:

Создать матрицу размера n x n, заполнить случайными числами от (-20 до 30). Сформировать одномерный массив от 1 до n, каждый элемент которого равен произведению положительных четных элементов данного столбца.

Решаем так (естественно все делаем в Excel):

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Public Sub glav_diag()
Dim i As Integer ' Индекс строки
Dim j As Integer ' Индекс столбца
Dim q As Double ' Переменная результата для столбца
Dim cond As Integer ' Дополнительная переменная. Сколько раз выполнилось условие. Ее в принципе можно сделать булевой
 
n = InputBox("n=") ' Просим ввести n - размерность массива. У нас он всегда квадратный
 
ReDim arr(n, n) ' Объявляем его
q = 1 ' Так как у нас по условию "произведение", то мы вынуждены написать тут 1, иначе (в случае 0) произведение всегда будет равно 0
cond = 0 ' условие пока не выполнилось
' Generation of array
For i = 1 To n
For j = 1 To n
arr(i, j) = Int((-20 - 30 + 1) * Rnd + 30) ' Рандом от -20 до 30
Cells(i, j).Value = arr(i, j) ' Забить это в ячейку
Cells(i, j).Interior.ColorIndex = xlNone ' Убрать цвет если он был
Next j
Next i
 
' Обработка и вычисления
For j = 1 To n
For i = 1 To n
If ((arr(i, j) > 0) And (arr(i, j) Mod 2 = 0)) Then ' Если значение массива больше 0 и четное
q = q * arr(i, j) ' тогда домножаем его на q и записываем новый результат в q
cond = cond + 1 ' Если условие выполнилось увеличиваем переменную
Cells(i, j).Interior.Color = vbCyan ' Закрашиваем соответствующую ячейку на листе цветом
End If
Next i
If (cond > 0) Then ' Если условие выше выполнилось хотя бы раз...
Cells(n + 1, j).Value = q ' тогда записываем значение вычислений в ячейку ниже нашей матрицы
Cells(n + 1, j).Interior.Color = vbGreen ' и красим в заленый
Else
Cells(n + 1, j).Value = 0 ' Если не выполнилось пишем туда 0 (таких элементов нет) просто q записать нельзя, так как он равен 1
Cells(n + 1, j).Interior.Color = vbGreen ' и тоже в зеленый
End If
cond = 0
q = 1
Next j
End Sub
Public Sub glav_diag()
Dim i As Integer ' Индекс строки
Dim j As Integer ' Индекс столбца
Dim q As Double ' Переменная результата для столбца
Dim cond As Integer ' Дополнительная переменная. Сколько раз выполнилось условие. Ее в принципе можно сделать булевой

n = InputBox("n=") ' Просим ввести n - размерность массива. У нас он всегда квадратный

ReDim arr(n, n) ' Объявляем его
q = 1 ' Так как у нас по условию "произведение", то мы вынуждены написать тут 1, иначе (в случае 0) произведение всегда будет равно 0
cond = 0 ' условие пока не выполнилось
' Generation of array
For i = 1 To n
For j = 1 To n
arr(i, j) = Int((-20 - 30 + 1) * Rnd + 30) ' Рандом от -20 до 30
Cells(i, j).Value = arr(i, j) ' Забить это в ячейку
Cells(i, j).Interior.ColorIndex = xlNone ' Убрать цвет если он был
Next j
Next i

' Обработка и вычисления
For j = 1 To n
For i = 1 To n
If ((arr(i, j) > 0) And (arr(i, j) Mod 2 = 0)) Then ' Если значение массива больше 0 и четное
q = q * arr(i, j) ' тогда домножаем его на q и записываем новый результат в q
cond = cond + 1 ' Если условие выполнилось увеличиваем переменную
Cells(i, j).Interior.Color = vbCyan ' Закрашиваем соответствующую ячейку на листе цветом
End If
Next i
If (cond > 0) Then ' Если условие выше выполнилось хотя бы раз...
Cells(n + 1, j).Value = q ' тогда записываем значение вычислений в ячейку ниже нашей матрицы
Cells(n + 1, j).Interior.Color = vbGreen ' и красим в заленый
Else
Cells(n + 1, j).Value = 0 ' Если не выполнилось пишем туда 0 (таких элементов нет) просто q записать нельзя, так как он равен 1
Cells(n + 1, j).Interior.Color = vbGreen ' и тоже в зеленый
End If
cond = 0
q = 1
Next j
End Sub

Вот такой простой код. Все комментарии в коде.

Скачать тестовым документом

Результат работы:

Continue reading

VBA: Выделить слова в Microsoft Word

Условие: Написать макрос для Word, который запрашивает слово и выделяет его каким-либо образом в тексте.

Алгоритм: пробежаться по всем словам в тексте, и если слово совпадает с заданным- применить к нему некоторые изменения.

Continue reading

Копирование ячеек с определенной позиции и с одного листа на другой в VBA

Вот такое дали:

Копировать клетки столбца D, начиная с клетки D5, с Листа 2 на Лист 1 до тех пор, пока сумма копируемых значений не станет больше 100.

Решить на VBA, в Excel соответственно.

Задача показалась ну сильно простой, однако, на ее решение ушло значительное время.

Continue reading