Программирование на visual basic

• Название: Программирование на visual basic
• Анкор: vb.pdf
• Дата: 05.06.2021
• Размер: 1.19 Mb.
• Имя файла: vb.pdf
• Тип: Учебное пособие; #214287
• страница: 13 из 17

s
– строка, в ко- торой необходимо переставить элементы;
i
и
j
– номера символов, которые необходимо переставить.
Sub swap(s As String, i As Long, j As Long)
Dim c As String * 1 c = Mid(s, i, 1): Mid(s, i, 1) = Mid(s, j, 1): Mid(s, j, 1) = c
End Sub
Sub Кодировщик()
Dim s As String, s1 As String, i As Long, Gl As String
Dim KL As String, c As String * 1, k As Long
Gl = "аеёиоыуэюя" ' алфавит гласных букв
' Символы, которые необходимо вставлять после гласных
KL = "фжшцщфхйчгфжщшцшжэюйцкнгшщзх"
Sheets("Лист2").Select : s = Cells(1, 3) s = s + "фжщ" ‘ В конец строки добавить три символа фжщ
s1 = "" ‘ В s1 получим новую более длинную строку
' В этом цикле в переменную s1 копируются символы из s и после
‘ каждой гласной добавить два редко встречающихсяе символа
‘ из строки KL
k=1
‘Номер символа из KL, который нужно вставлять после гласных

110
For i = 1 To Len(s) c = Mid(s, i, 1): s1 = s1 + c
If InStr(1, Gl, c, 1) > 0 Then
If k > Len(KL) - 1 Then k = 1
'Символы кончились в KL, начинаем сначала
s1 = s1 + Mid(KL, k, 2) ' Добавляем два символа из KL k = k + 2 ‘ Перейти к следующей паре символов
End If
Next i
Cells(2, 3) = s1 ‘Выводим промежуточный результат
' Переставить 1-ый символ с 4-ым, 2-ой с 3-им и т.д.
For i = 1 To Len(s1) - 3 Step 4
‘поменять i-тый и i+3-тий символы в строке s1
Call swap(s1, i, i + 3)
Call swap(s1, i + 1, i + 2)
Next i
Cells(3, 3) = s1 ‘ Вывести зашифрованный текст в ячейку
End Sub
9.2.2. Расшифровать текст, зашифрованный по предыдущему правилу.
Sub Раскодировщик()
Dim s As String, s1 As String, i As Long, Gl As String, c As String * 1
Sheets("Лист2").Select s1 = Cells(3, 3) ‘ Ввести зашифрованный текст в строку s1
' Переставить 1-ый символ с 4-ым, 2-ой с 3-им
For i = 1 To Len(s1) - 3 Step 4
‘Поменять i-тый и i+3-тий символы в строке s1
Call swap(s1, i, i + 3)
Call swap(s1, i + 1, i + 2)
Next i
Gl = "аеёиоыуэюя": s = ""
' Копировать s1 в s, при этом пропускать два символа после
‘ гласных
For i = 1 To Len(s1) –3 ‘Последние 3 символа не копировать в s c = Mid(s1, i, 1): s = s + c
If InStr(1, Gl, c, 1) > 0 Then i = i + 2 ‘ Пропустить два символа
Next I
‘Записать расшифрованный текст в ячейку рабочего листа
Cells(4, 3) = s
End Sub
9.2.3. При работе в текстовом процессоре Word часто пользователь за- бывает перейти на нужный алфавит (русский или латинский) и набирает текст на альтернативном алфавите. Написать программу, которая преобра- зует в выделенном тексте символы, набранные на латинском регистре на символы русского регистра.
Решение. Введем две символьные переменные alphRus и alphEng. В первую переменную запишем все русские символы, кроме букв э и Э. Во

111
вторую переменную запишем те же буквы, но на латинском регистре.
Дальше в переменную st считывается выделенный текст. В цикле по всем символам проверяем каждый символ, является ли он русским символом, набранным на латинском регистре. Если является, то меняем на соответст- вующий символ, набранный на русском алфавите. Символ “, имеющий код
34, ищем при помощи функции Asc и заменяем его на букву Э. Символы с кодом 145 или 146 соответствуют апострофам ‘’, заменяем их на букву э.
Sub ИнвертироватьEnglishНаРусские()
Dim st, sn, alphRus As String, alphEng As String, i, Nc, c As String * 1
' Все клавиши на русском регистре alphRus = "йцукенгшщзхъфывапролджячсмитьбюё" + _
"ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЯЧСМИТЬБЮЁ"
' Соответствующие русским клавиши на латинском регистре alphEng = "qwertyuiop[]asdfghjkl;zxcvbnm,.`" + _
"QWERTYUIOP{}ASDFGHJKL:ZXCVBNM<>

"
'Переписать выделенный фрагмент в переменную st st = Selection.Text
For i = 1 To Len(st) ‘ Обойти по всем символам строки st c = Mid(st, i, 1) ' Считать i-тый символ из строки st
If Asc( с ) = 34 Then Mid(st, i, 1) = "Э" ' Символ "
If Asc( с ) = 145 Or Asc( с ) = 146 Then Mid(st, i, 1) = "э" ' Символы '’
Nc = InStr(alphEng, c) ' Номер символа в переменной alphEng
‘ Если c символ из alphEngl, то заменить
‘соответстветствующим русским символом
If Nc > 0 Then Mid(st, i, 1) = Mid(alphRus, Nc, 1)
Next i
' Перезаписать st в выделенный фрагмент текста
Selection.Text = st
End Sub
9.2.4. Написать программу, которая инвертирует текст, ошибочно набранный на русском регистре вместо латинского.
Sub ИнвертироватьРусскиеНаEnglish()
Dim st, sn, i, Nc, alphRus As String, alphEng As String, c As String * 1 alphRus = "йцукенгшщзхъфывапролджячсмитьбюё” + _
”ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЯЧСМИТЬБЮЁ" alphEng = "qwertyuiop[]asdfghjkl;zxcvbnm,.`” + _
QWERTYUIOP[]ASDFGHJKL;ZXCVBNM,." st = Selection.Text
For i = 1 To Len(st) ‘ Обойти по всем символам строки st
c = Mid(st, i, 1) ' Считать i-тый символ из строки st
If c = "Э" Then Mid(st, i, 1) = Chr(34) ' Символ " (кавычки)
If c = "э" Then Mid(st, i, 1) = Chr(146) ' Символ ' (апостроф)
Nc = InStr(alphRus, c)
If Nc > 0 Then Mid(st, i, 1) = Mid(alphEng, Nc, 1)
Next i
Selection.Text = st

112
End Sub
10. Задачи на массивы
10.1. Одномерные массивы натуральных чисел
10.1.1. Подсчитать количество простых натуральных пятизначных чи- сел.
Sub ПростыхПятизначныхЧисел()
Dim NSimple As Long, a As Long, i As Long
‘ Обойти все пятизначные числа
For i = 10000 To 99999
If Simple(i) Then NSimple = NSimple + 1
Next i
Debug.Print "Простых пятизначныхчисел="; NSimple
End Sub
‘ Логическая функция, отвечающая на вопрос: простое ли число а?
Function Simple(a As Long) As Boolean
Dim i As Long
Simple = False
For i = 2 To a \ 2 ‘ Обойти по всем целым числам от 2 до a\2
If a Mod i = 0 Then Exit Function ‘ Если a делится на i, то a простое
Next i
‘ a не делится на целые числа от 2 до a\2. Да, простое.
Simple = True
End Function
Замечание. Нетрудно заметить, что проверку на делимость исследуемо- го числа a
, можно проводить до значения равного
a
. При этом заглавие цикла будет следующим:
For i = 2 To sqr(a)
В этом случае для больших значений исследуемого числа a, программа будет работать значительно быстрее.
10.1.2. При помощи датчика случайных чисел сгенерировать N случай- ных трехзначных чисел и вывести их в первый столбец рабочего листа
Excel. При этом ячейки, в которых находятся простые числа, выделить цветом. Число N ввести с клавиатуры.
Sub ПростыеЧислаВыделитьЦветом()
Dim a As Long, N As Long, i As Integer
Randomize Timer ' Построить ряд случайных чисел
N = Val(InputBox("Введите количество элементов"))
Sheets("Лист1").Select
Columns("A:A").Clear ' Очистить столбец A
For i = 1 To N a = Rnd * 899 + 100 ' Получить трехзначное случайное число a
Cells(i, 1) = a ' Записать его в i-тую строку столбца A

113
' если a простое число, то вызвать подпрограмму
’ для заполнения ячейки ai цветом номер 22
If Simple(a) Then Call FillColor(i, "a", 22)
Next i
End Sub
' Подпрограмма, которая закрашивает ячейку, стоящую в i – той
‘строке столбца c и цветом номер Color (от 0 до 55)
' функция Trim удаляет пробелы слева и справа в строке Str(i)
Sub FillColor(i As Integer, c As String, Color As Integer)
Range(c + Trim(Str(i))).Select ' выделить ячейку ci
With Selection.Interior ‘ залить ячейку цветом
.ColorIndex = Color ‘ номер цвета
.Pattern = xlSolid ‘ стиль заполнения
End With
End Sub
10.1.3. При помощи датчика случайных чисел сгенерировать массив из
N случайных шестизначных чисел и вывести их во второй столбец рабоче- го листа Excel. Подсчитать количество счастливых чисел. Если количество счастливых чисел четно, то ячейки, в которых находятся счастливые числа, выделить цветом. N вводится с клавиатуры. Шестизначное число называ- ется счастливым, если сумма первых трех цифр равна сумме последних трех цифр.
Sub СчастливыеЧислаВыделитьЦветом()
Dim a() As Long, N As Long, i As Integer, NHappy As Integer
Randomize Timer ' построить ряд случайных чисел
N = Val(InputBox("Введите количество элементов"))
ReDim a(N) ‘ создать динамический массив
Sheets("Лист1").Select
Columns("B:B").Clear ' очистить столбец A
For i = 1 To N
' Получить случайное шестизначное число a a(i) = Rnd * 899999 + 100000
Cells(i, 2) = a(i) ' Записать его в i-тую строку столбца B
' подсчет количества счастливых чисел
If Happy(a(i)) Then NHappy = NHappy + 1
Next i
If (NHappy Mod 2) = 0 Then ‘ Если Nhappy четно
For i = 1 To N
' Если a счастливое число, то вызвать подпрограмму FillColor
If Happy(a(i)) Then Call FillColor(i, "B", 35)
Next i
End If
MsgBox ("Всего счастливых чисел=" + Str(NHappy))
End Sub
Function Happy(a As Long) As Boolean
Dim N1 As Integer, N2 As Integer, N3 As Integer, N4 As Integer, N5 As Integer

114
Dim N6 As Integer ' Ni - i-тая цифра в числе
N1 = a \ 100000 : N2 = (a \ 10000) Mod 10
N3 = (a \ 1000) Mod 10 : N4 = (a \ 100) Mod 10
N5 = (a \ 10) Mod 10 : N6 = a Mod 10
‘ Истина, если сумма первых трех цифр равна сумме вторых
‘ трех цифр
Happy = N1 + N2 + N3 = N4 + N5 + N6
End Function
10.1.4. При помощи датчика случайных чисел сгенерировать массив из
N случайных натуральных чисел различных порядков и вывести их в чет- вертый столбец рабочего листа Excel. В пятый столбец вывести преобра- зованные числа по следующему правилу:
• если число простое, то вывести то же число, но ячейку выделить цве- том, номер которого равен остатку от деления количества простых чи- сел на 55;
• если число составное, то его инвертировать. Т.е. записать цифры в обратном порядке.
Решение.
Задача решается двумя методами.
Sub ИнвертироватьНепростыеЧисла()
Dim a() As Long, N As Long, i As Integer, NSimple As Integer
Dim Color As Integer, st As Long
Randomize Timer ' Построить ряд случайных чисел
N = Val(InputBox("Введите количество элементов"))
ReDim a(N)
Sheets("Лист1").Select
Columns("D:E").Clear ' Очистить столбцы D и E
For i = 1 To N st = 10 ^ Int(Rnd * 6 + 1.5) ' Случайное количество цифр в числе a(i) = Rnd * st ' Получить случайное число в диапазоне от 0 до st
Cells(i, 4) = a(i)
If Simple(a(i)) Then NSimple = NSimple + 1’ Кол-во простых чисел
Next i
Color = NSimple Mod 55 ‘ Выбрать номер цвета
For i = 1 To N
If Simple(a(i)) Then
Cells(i, 5) = a(i): Call FillColor(i, "E", Color)
Else
‘ Записать инвертированное число
Cells(i, 5) = InvertNumber1(a(i)) ‘Первый метод
‘ Cells(i, 5) = InvertNumber2(a(i)) ‘Второй метод
End If
Next i
End Sub
‘ Первый метод инвертирования целого числа
Function InvertNumber1(ByVal a As Long) As Long
Dim numb As Integer, inva As Long, b As Long, e As Long, k As Integer

115
Dim d As Integer numb = Int(Log10(a + 0.0001)) + 1 ‘ Количество цифр в числе a
b = 10 ^ (numb - 1): e = 1
For k = 1 To numb ‘ Цикл по всем цифрам числа
d = a \ b ' 1-ая цифра слева числа a a = a - d * b 'Убрать 1-ую цифру слева числа a b = b \ 10 inva = inva + d * e ‘ Добавить цифру d слева к числу inva e = e * 10
Next k
InvertNumber1 = inva ‘Инвертированное число
End Function
‘ Второй метод инвертирования целого числа с использованием
‘строковых функций
Function InvertNumber2(ByVal a As Long) As Long
Dim numb As Integer, inva As String, t As String * 1, i As Integer inva = Str(a) ‘Преобразовать целое число в строку numb = Len(inva) ‘ Длина строки
For i = 1 To numb \ 2
‘ Обмен симметричных относительно центра строки символов
t = Mid(inva, i, 1): Mid(inva, i, 1) = Mid(inva, numb + 1 - i)
Mid(inva, numb + 1 - i) = t
Next i
InvertNumber2 = Val(inva) ‘ Преобразовать строку в целое число
End Function
10.2. Задачи на одномерные массивы действительных
чисел
10.2.1. С клавиатуры вводится массив положительных действительных чисел размерности N. Не изменяя целую часть всех элементов массива, дробной части присвоить среднеарифметическое значение дробных частей всего массива с точностью три знака после запятой.
Sub СреднееЗначениеДробныхЧастей()
Dim s As Double, a() As Double, i As Long, N As Long, d As Double
N = Val(InputBox("Введите размерность массива"))
ReDim a(N) s = 0
For i = 1 To N a(i) = CDbl(InputBox("Введите элемент массива номер " + Str(i))) d = a(i) - Fix(a(i)) ‘ Дробная часть числа s = s + d ‘ Накопление суммы дробных частей
Debug.Print Tab((i - 1) * 10); Format(a(i), "#0.000");
‘ После 8 элем. перейти к другой строке
If (i Mod 8) = 0 Then Debug.Print
Next i s = Int(1000 * s / N+0.5) / 1000 ‘Округлить до трех знаков

116
Debug.Print ‘Перейти на другую строку
For i = 1 To N
‘К целой части добавить среднее значение дробной a(i) = Int(a(i)) + s
Debug.Print Tab((i - 1) * 10); Format(a(i), "#0.000");
If (i Mod 8) = 0 Then Debug.Print
Next i
End Sub
10.2.2. При помощи датчика случайных чисел получить массив A из N положительных действительных чисел в диапазоне от 1 до 1000 с тремя знаками после запятой. На базе массива A получить массив B, поменяв целую и дробную части местами.
Sub ЦелуюЧастьПоменятьНаДробную()
Dim a() As Double, b() As Double, d As Double
Dim i As Long, N As Long, numb As Long
N = Val(InputBox("Введите размерность массива"))
ReDim a(N), b(N)
Randomize Timer
Sheets("Лист1").Select: Range("a1:b100").Clear
For i = 1 To N
' Это случайные действительные числа от 1 до 1000
d = Rnd * 899 + 100
' Округлить d до трех знаков после запятой
a(i) = Int(d * 1000 + 0.5) / 1000
Cells(i, 1) = a(i) ' Вывести в первый столбец рабочего листа
Next i
For i = 1 To N numb = Int(a(i)) ' Целая часть числа d = a(i) - numb ' Дробная часть числа
' + 0.0000000001 из-за небольшой ошибки при вычитании d
‘ может быть < b(i) = Int(d * 1000 + 0.0000000001) + numb / 1000
Cells(i, 2) = b(i) ‘ Вывести результат во второй столбец
Next i
End Sub
10.2.3. При помощи датчика случайных чисел получить массив A из N действительных чисел в диапазоне от –999 до 999. На основании массива
A получить массив B по следующему правилу: если A
i отрицательное, то
B
i равно сумме цифр целой части числа, а если A
i положительное, то B
i равно сумме первых трех цифр дробной части.
Sub СуммаЦифрЦелойИДробнойЧастей()
Dim a() As Double, b() As Double, d As Double
Dim i As Long, N As Long, numb As Long
N = Val(InputBox("Введите размерность массива"))
ReDim a(N), b(N)
Randomize Timer

117
Sheets("Лист1").Select: Range("a1:b100").Clear
For i = 1 To N d = Rnd * 1998 - 999 ' Это действительные числа от -999 до 999
' округлить d до 4 знаков после запятой a(i) = Int(d * 10000 + 0.5) / 10000
Cells(i, 1) = a(i) ' Вывести в первый столбец рабочего листа
Next i
For i = 1 To N numb = Int(Abs(a(i))) ' Целая положительная часть числа d = Abs(a(i)) - numb ' Дробная часть числа
If a(i) < 0 Then
' Первая цифра + вторая цифра + третья цифра целой части
‘ трехзначного числа
b(i) = numb \ 100 + (numb - (numb \ 100) * 100) \ 10 + (numb Mod 10)
Else
' Первая цифра + вторая цифра + третья цифра дробной части
b(i) = Int(d * 10) + (Int(d * 100) Mod 10) + (Int(d * 1000) Mod 10)
End If
Cells(i, 2) = b(i)
Next i
End Sub
10.2.4. При помощи датчика случайных чисел получить последователь- ность действительных чисел в диапазоне от –100 до 200. Подсчитать мак- симальную длину подпоследовательностей отрицательных элементов, за- ключенных между двумя неположительными элементами.
Sub ДлинаПодпоследовательностиОтрицательныхЧисел()
Dim a As Long, maxnumb As Long, numb As Long, N As Long
Dim flag As Boolean, i As Long
N = _
Val(InputBox("Введите количество элементов последовательности"))
Randomize Timer
Sheets("Лист1").Select: Range("a1:a100").Clear flag = True: numb = 0: maxnumb = 0
For i = 1 To N
' Это случайные действительные числа от -100 до 200
a = Rnd * 300 - 100
Cells(i, 1) = a ' Вывести в первый столбец рабочего листа
If flag Then
‘ Находится внутри цепочки отрицательных элементов
If a < 0 Then numb = numb + 1
Else ‘ Вышли из цепочки отрицательных элементов
‘ Флажок “в цепочке отрицательных элементов” сбросить
flag = False
If numb > maxnumb Then maxnumb = numb ‘Длина > предыдущих?
End If
Else ’ Вне цепочки отрицательных элементов

118
If a < 0 Then ‘ Вошли в цепочку отрицательных элементов
numb = 1: flag = True
End If
End If
Next i
Debug.Print "максимальная длина отрицательных элементов = "; _ maxnumb
End Sub
10.2.5. При помощи датчика случайных чисел получить последователь- ность действительных чисел в диапазоне от –100 до 200. Подсчитать мак- симальную сумму подпоследовательностей положительных элементов, за- ключенных между двумя неотрицательными элементами.
Sub СуммаПодпоследовательностиПоложительныхЧисел()
Dim a As Double, maxSum As Double, Sum As Double, N As Long
Dim flag As Boolean, i As Long
N = _
Val(InputBox("Введите количество элементов последовательности"))
Randomize Timer
Sheets("Лист1").Select: Range("a1:a100").Clear flag = True: Sum = 0: maxSum = 0
For i = 1 To N a = Rnd * 300 – 100
' Это случайные действительные числа от -100 до 200
Cells(i, 1) = a ' Вывести в первый столбец рабочего листа
If flag Then
‘ Находится внутри цепочки положительных элементов
If a > 0 Then
Sum = Sum + a
Else ‘ Вышли из цепочки положительных элементов
‘ Флажок “в цепочке положительных элементов” сбросить
If Sum > maxSum Then maxSum = Sum flag = False
‘ Сумма > предыдущих сумм?
End If
Else ’ Вне цепочки положительных элементов
If a > 0 Then ‘ Вошли в цепочку положительных элементов
Sum = a: flag = True
End If
End If
Next i
Debug.Print "максимальная сумма положительных элементов = "; maxSum
End Sub
10.2.6. Из массива действительных чисел, находящихся с первой строки и до первой пустой строки столбца A рабочего листа Excel, убрать повто- ряющиеся числа.

119
Sub УбратьПовторяющиесяЧисла()
Dim a() As Double, n As Long, k As Long, i As Long, j As Long
Sheets("Лист1").Select n = 0: k = 0
While Cells(n + 1, 1) <> Empty ' пока в следующей строке не пусто n = n + 1
' Изменить размер массива сохраняя (Preserve) значения
‘ элементов массива до изменения размерности
ReDim Preserve a(n) a(n) = Cells(n, 1) ‘ Считать содержимое ячейки в массив a
Wend
Range("b1:b" + Trim(Str(n))).Clear ' Очистить ячейки
For i = 1 To n
For j = 1 To i - 1 ' Есть ли a(i) среди первых i-1 элементов
If a(j) = a(i) Then GoTo nexti ' Есть, поэтому его пропустить
Next j k = k + 1 ' Элемент не повторяющийся
Cells(k, 2) = a(i) ' Записать его в строку номер k второго столбца nexti: Next i
End Sub
10.2.7. В области “a1:i100” рабочего листа Excel находятся действи- тельные числа или пустые ячейки. Подсчитать общее число пустых ячеек и какое число чаще других встречается в указанных ячейках.
Sub КакоеЧислоЧащеВстречается()
Dim a(900) As Double, k As Long, nEmpty As Long, numb As Long
Dim i As Long, j As Long, max As Double, NMax As Long
Sheets("Лист1").Select k = 0 ' Номер непустой ячейки
' Обход по всем ячейкам области "a1:i100"
For i = 1 To 100
For j = 1 To 9
If Cells(i, j) <> Empty Then k = k + 1
' Если ячейка не пустая, считать ее содержимое в массив a
a(k) = Cells(i, j) ' Запомнить очередной элемент в массиве
End If
Next j, i
Debug.Print "Число непустых ячеек= "; 900 - k
NMax = 0 ' Максимальное количество одинаковых чисел
For i = 1 To k numb = 0 ' Число элементов = a(i)
For j = 1 To k ' Сколько элементов массива a = элементу a(i)
If a(j) = a(i) Then numb = numb + 1
Next j
'Если элементов a(i) > чем других элементов a(k), где k
If numb > NMax Then
NMax = numb: max = a(i) ' Запомнить новые значения

120
End If
Next i
Debug.Print "Наиболее часто встречается число "; max; _
" Оно встречается "; NMax; " раза"
End Sub