Модератор
1123
Советник
681
Академик
574
Специалист
401
Мастер-Эксперт
196
Профессионал
186
Профессор
137
8.2.5
01.03.2021
JS: 2.3.4
CSS: 4.3.16
jQuery: 3.5.1
Установка, настройка и работа в пакете Microsoft Office.
Администратор раздела: Megaloman (Мастер-Эксперт)
|
Перейти к консультации №: |
|
Здравствуйте! У меня возникли сложности с таким вопросом:
Буду очень благодарен если поможете написать код к задачам ниже на языке VBA (смотреть картинку)
-----
Прикрепленное изображение (кликните по картинке для увеличения):
Состояние: Консультация закрыта
Здравствуйте, 23071996! На будущее: одна задача-один вопрос, быстрее получите ответы, не всякий эксперт найдёт время сделать всю кучу задач.
Коды макросов Excel
Sub Sub_3_6() Const ShName = "3.6" ' Имя листа с массивом A Sheets(ShName).Select Cells.Interior.Pattern = xlNone Cells.Font.ColorIndex = xlAutomatic Dim R1, R2, A, N1, N2, i, ii R1 = Selection.Address If InStr(R1, ":") > 0 Then MsgBox "Для первого элемента массива" + vbCrLf + _ "выбран диапазон ячеек, а необходимо одна" + vbCrLf + vbCrLf + _ """" + R1 + """" Exit Sub End If If IsEmpty(Range(R1)) Or Not IsNumeric(Range(R1)) Then MsgBox "Для первого элемента массива" + vbCrLf + _ "выбрана либо пустая, либо ячейка не с числом" + vbCrLf + vbCrLf + _ """" + R1 + """= """ + Range(R1) + """" Exit Sub End If R2 = Selection.End(xlDown).Address If IsEmpty(Range(R2)) Or Len(Trim(Range(R2))) = 0 Then R2 = R1 N1 = 1 N2 = 1 ReDim A(1 To 1, 1 To 1) A(1, 1) = Range(R1) Else A = Range(R1 + ":" + R2) N1 = LBound(A) N2 = UBound(A) End If ReDim B(N1 To N2) Dim S, M, MMax ii = 0 MMax = 0 For i = N1 To N2 Range(R1).Offset(ii, 1) = "" B(i) = 0 If IsNumeric(A(i, 1)) Then S = "" M = 0 Call MultiProst(A(i, 1), 2, S, M) B(i) = M If M > MMax Then MMax = M Range(R1).Offset(ii, 0).Font.Color = -11489280 Range(R1).Offset(ii, 1) = "=""" + Replace(S, "*", "=", 1, 1) + """" Else Range(R1).Offset(ii, 0).Font.Color = -16776961 End If ii = ii + 1 Next With Selection.Font .Color = -11489280 .TintAndShade = 0 End With ii = 0 For i = N1 To N2 If B(i) = MMax Then Range(R1).Offset(ii, 0).Interior.Color = 65535 End If ii = ii + 1 Next End Sub Sub MultiProst(X, i1, S, M) If X = 1 Or X = 0 Or Int(X) <> X Then Exit Sub For k = i1 To X XX = X Mod k If XX = 0 Then M = M + 1 S = S + "*" + CStr(k) Call MultiProst(X / k, k, S, M) Exit For End If Next End Sub ' ==================== Sub Sub_3_7() Dim N, CN, ierr, S, SS, i N = InputBox("Введите целое N>0") ierr = False If IsNumeric(N) Then CN = CDbl(N) If CDbl(CN) > 0 And Int(CN) = CN Then ierr = True S = 0 SS = 0 For i = 1 To CN SS = SS + Sin(i) S = S + 1 / SS ' MsgBox CStr(i) + vbCrLf + CStr(SS) + vbCrLf + CStr(S) Next End If End If If ierr Then MsgBox "N= " + CStr(CN) + vbCrLf + "S= " + CStr(S) Else MsgBox "Введено неверное число" + vbCrLf + N End If End Sub ' ==================== Sub Sub_3_8() Const a1 = 1 Const b1 = 2 Const c1 = 50 Const a2 = -8 Const b2 = 4 Const c2 = 0 Const eps = 0.000001 Dim delta, d Dim X, y Dim Out Out = _ "a1= " + CStr(a1) + vbCrLf + _ "b1= " + CStr(b1) + vbCrLf + _ "c1= " + CStr(c1) + vbCrLf + vbCrLf + _ "a2= " + CStr(a2) + vbCrLf + _ "b2= " + CStr(b2) + vbCrLf + _ "c2= " + CStr(c2) + vbCrLf + vbCrLf delta = a1 * b2 - a2 * b1 d = Abs(delta) Out = Out + "d= " + CStr(b1) + vbCrLf + vbCrLf If d > eps Then X = (c1 * b2 - c2 * b1) / delta y = (a1 * c2 - a2 * c1) / delta Out = Out + _ "x= " + CStr(X) + vbCrLf + _ "y= " + CStr(y) + vbCrLf Else Out = Out + "система не имеет решения" End If MsgBox Out End Sub ' ==================== Sub Sub_3_9() Const ShName = "3.9" ' Имя листа с матрицей A Const RA = "B3" ' Адрес ячейки с верхним левым элементом матрицы A Const N = 8 ' Размерность матрицы Const RB = "B13" ' Адрес ячейки с верхним левым элементом матрицы B Sheets(ShName).Select Dim RRA, A, N1, N2, i, j Dim Maxi, Maxj, Maxx RRA = RA + ":" + Range(RA).Offset(N - 1, N - 1).Address A = Range(RRA) N1 = LBound(A, 1) N2 = UBound(A, 1) Dim RRB, ii, jj RRB = RB + ":" + Range(RB).Offset(N - 2, N - 2).Address ReDim B(N1 To N2 - 1, N1 To N2 - 1) Maxi = N1 Maxj = N1 Maxx = Abs(A(Maxi, Maxj)) For i = N1 To N2 For j = N1 To N2 If Abs(A(i, j)) > Maxx Then Maxx = Abs(A(i, j)) Maxi = i Maxj = j End If Next Next Range(RRA).Interior.Pattern = xlNone ' Range(RRA).Font.ColorIndex = xlAutomatic ii = N1 For i = N1 To N2 jj = N1 For j = N1 To N2 If i = Maxi Or j = Maxj Then Range(RA).Offset(i - 1, j - 1).Interior.Color = 65535 Else B(ii, jj) = A(i, j) jj = jj + 1 End If Next If i <> Maxi Then ii = ii + 1 Next Range(RRB) = B End Sub ' ====================
|
Консультировал: Megaloman (Мастер-Эксперт) Дата отправки: 19.02.2021, 23:30 |
Рейтинг ответа:
+1 Сообщение модераторам Отправлять сообщения |
Мастер-Эксперт ID: 259041
+1
|
23071996: Ваш Вопрос не содержит полноценной сути в текстовом формате. Такие "ленивые" вопросы НЕ индексируются на поисковых сайтах, не аннотируются в перечне "RFpro.ru - Вопросы" rfpro.ru/rss/questions.rss, не добавляют рейтинг порталу rfpro.ru . |
Возможность оставлять сообщения в мини-форумах консультаций доступна только после входа в систему.
Воспользуйтесь кнопкой входа вверху страницы, если Вы зарегистрированы или пройдите простую процедуру регистрации на Портале.