Родились сегодня:
goldssky@yandex.ru


Лидеры рейтинга

ID: 226425

Konstantin Shvetski

Модератор

770

Россия, Северодвинск


ID: 259041

Алексеев Владимир Николаевич

Мастер-Эксперт

343

Россия, пос. Теплоозёрск, ЕАО


ID: 401284

Михаил Александров

Академик

279

Россия, Санкт-Петербург


ID: 325460

CradleA

Мастер-Эксперт

212

Беларусь, Минск


ID: 137394

Megaloman

Мастер-Эксперт

148

Беларусь, Гомель


ID: 400815

alexleonsm

6-й класс

130


ID: 400669

epimkin

Профессионал

120


8.8.15

09.05.2021

JS: 2.8.21
CSS: 4.5.5
jQuery: 3.6.0
DataForLocalStorage: 2021-05-13 03:16:01-standard


Установка, настройка и работа в пакете Microsoft Office.

Администратор раздела: Megaloman (Мастер-Эксперт)

Консультация онлайн # 200291

Раздел: Пакет MSOffice
Автор вопроса: 23071996 (Посетитель)
Дата: 18.02.2021, 21:31 Консультация закрыта
Поступило ответов: 1

Здравствуйте! У меня возникли сложности с таким вопросом:
Буду очень благодарен если поможете написать код к задачам ниже на языке VBA (смотреть картинку)

Последнее редактирование 19.02.2021, 09:40 Сергей Фрост (Управляющий)
Ответ # 280761 от Megaloman
Здравствуйте, 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
' ====================
        

Здесь таблица с примерами ya210220.xlsm (27.1 кб)

Megaloman

Мастер-Эксперт
19.02.2021, 23:30
5
Мини-форум консультации # 200291

q_id

Алексеев Владимир Николаевич

Мастер-Эксперт

ID: 259041

1

= общий =    19.02.2021, 02:39
23071996:

Ваш Вопрос не содержит полноценной сути в текстовом формате. Такие "ленивые" вопросы НЕ индексируются на поисковых сайтах, не аннотируются в перечне "RFpro.ru - Вопросы" rfpro.ru/rss/questions.rss, не добавляют рейтинг порталу rfpro.ru .

Эксперты помогают в первую очередь тем, кто сформулировал проблему текстом и сделал хоть что-то для решения своей задачи.
Картинку полезно прикрепить т-ко как доп-инфо, чтоб уточнить графику (схему, формулу, греческие буквы…).

Вы переложили на головы экспертов не только решение своей задачи, но ещё и предвари-распознавание текста из картинки. Помочь всем лодырям мы не успеваем.

Если уж Вы записались в эксперты, то прочтите ПравилаПортала, хотя бы часть "Как правильно задавать вопросы?" rfpro.ru/help/questions#30

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

Лучшие эксперты раздела

CradleA

Мастер-Эксперт

Рейтинг: 212

Megaloman

Мастер-Эксперт

Рейтинг: 148

Зенченко Константин Николаевич

Старший модератор

Рейтинг: 74

solowey

Профессор

Рейтинг: 21

SFResid

Мастер-Эксперт

Рейтинг: 2

Степанов Иван /REDDS

4-й класс

Рейтинг: 1