Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Пакет Microsoft Office

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 2.040 RSS
←   Февраль 2021   →
 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


За последние 60 дней ни разу не выходила


Сайт рассылки: http://rusfaq.ru
Открыта: 03-03-2006

Автор
Калашников О.А.

Статистика

2.040 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Пакет Microsoft Office


РАССЫЛКИ ПОРТАЛА RFPRO.RU

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

Megaloman
Статус: Мастер-Эксперт
Рейтинг: 195
∙ повысить рейтинг » 		CradleA
Статус: Академик
Рейтинг: 85
∙ повысить рейтинг » 		Valery N
Статус: Мастер-Эксперт
Рейтинг: 1
∙ повысить рейтинг »

∙ Пакет MSOffice

Номер выпуска:1027
Дата выхода:23.02.2021, 21:45
Администратор рассылки:Megaloman (Мастер-Эксперт)
Подписчиков / экспертов:32 / 30
Вопросов / ответов:1 / 1

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

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

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

Дата отправки: 18.02.2021, 21:31
Вопрос задал: 23071996 (1-й класс)
Всего ответов: 1
Страница онлайн-консультации »

Консультирует 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
Рейтинг ответа:

НЕ одобряю +1 одобряю!

Оценить выпуск | Задать вопрос экспертам

главная страница  |  стать участником  |  получить консультацию
техническая поддержка

Дорогой читатель!
Команда портала RFPRO.RU благодарит Вас за то, что Вы пользуетесь нашими услугами. Вы только что прочли очередной выпуск рассылки. Мы старались. Пожалуйста, оцените его. Если совет помог Вам, если Вам понравился ответ, Вы можете поблагодарить автора - для этого в каждом ответе есть специальные ссылки. Вы можете оставить отзыв о работе портале. Нам очень важно знать Ваше мнение. Вы можете поближе познакомиться с жизнью портала, посетив наш форум, почитав журнал, который издают наши эксперты. Если у Вас есть желание помочь людям, поделиться своими знаниями, Вы можете зарегистрироваться экспертом. Заходите - у нас интересно!
МЫ РАБОТАЕМ ДЛЯ ВАС!
В избранное