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
' ====================