Excel VBA Макросы: Выделить в диапазоне все зависимые строки

[nightofpromises]

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

В диапазоне могут быть не только числовые, но и текстовые данные, поэтому должны быть две проверки:
1) является ли данное записанное в ячейке - числом или нет, если нет - то обойти ячейку;
2) проверка деления на 0, если число в ячейке делится на 0, обойти ячейку.

Задание надо сделать в модуле-классе. А в обычном модуле (основном) надо создать экземпляр объектов этого модуля-класса.

Вот код макроса для главного модуля, где будут создаваться экземпляры класса-модуля:

Спойлер

Option Explicit
Sub ОбработатьДиапазон()
Dim Диапазон As КлассДиапазон
Set Диапазон = New КлассДиапазон
Set Диапазон.Область = Worksheets("Практическая №2").Range("D7:H12")
Диапазон.Определитькоэффициент (True)
Set Диапазон = Nothing
End Sub

[свернуть]

Прилагаю скриншот в качестве вложения.
Как мне все это реализовать? Помогите мне пожалуйста. А то я уже который день не могу придумать оптимальный алгоритм для решения данной задачи.

[Администратор]

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

Макрос сделан на основе фото из первого сообщения, поэтому вам надо тестировать на листе с такой-же структурой, как на фото в первом сообщении. То есть таблица должна располагаться в D7:H12. Данные в таблице могут быть любые.

Макрос

Sub макрос()
   
    Dim rng As Range, kef As Double
    Dim i As Long, ii As Long, j As Long
   
   
    '1. Присваивание имени "rng" фрагменту, в котором данные.
        ' Так удобнее будет писать и читать код.
    Set rng = Range("D7:H12")
   
    ' Цикл от первой строки до предпоследней.
    For i = 1 To rng.Rows.Count - 1
       
        '2. Проверка, нет ли в текущей строке нечисел. Если есть,
            ' то смысла сравнивать строку с другими нет.
        For j = 1 To rng.Columns.Count
            If IsNumeric(rng.Cells(i, j)) = False Then
                GoTo metka_NextI
            End If
        Next j
   
        ' Цикл от текущей строки + 1 до последней строки.
        For ii = i + 1 To rng.Rows.Count
           
            '3. Проверка, нет ли во второй строке нечисел и нулей.
            For j = 1 To rng.Columns.Count
                If IsNumeric(rng.Cells(ii, j)) = False Then
                    GoTo metka_NextII
                End If
                If rng.Cells(ii, j) = 0 Then
                    GoTo metka_NextII
                End If
            Next j
           
            '4. Расчёт кэфа для первой пары.
                ' Такой же кэф должен быть и в остальных парах.
            kef = rng.Cells(i, 1).Value / rng.Cells(ii, 1).Value
           
            '5. Расчёт кэфов в остальных парах и сравнение его с кэфом в переменной "kef".
            For j = 2 To rng.Columns.Count
                ' Если текущий кэф другой, то значит строки независимые.
                    ' Остальные пары нет смысла сравнивать.
                If rng.Cells(i, j) / rng.Cells(ii, j) <> kef Then
                    GoTo metka_NextII
                End If
            Next j
           
            '6. Если макрос дошёл до сюда, значит кэфы у всех пар равны и строки зависимые.
                ' Закраска строк.
            rng.Rows(i).ActiveCell.Interior.Color = 11854022
            rng.Rows(ii).ActiveCell.Interior.Color = 11854022
           
metka_NextII:
        Next ii
       
metka_NextI:
    Next i

End Sub

[свернуть]

[nightofpromises]

Вы можете без оператора GoTo обойтись в коде? А так код работает и все хорошо, просто преподаватель сказал что нежелательно использовать этот оператор

[Администратор]

Вариант без GoTo:

Макрос

Sub макрос()
   
    Dim rng As Range, kef As Double
    Dim i As Long, ii As Long, j As Long
   
   
    '1. Присваивание имени "rng" фрагменту, в котором данные.
        ' Так удобнее будет писать и читать код.
    Set rng = Range("D7:H12")
   
    ' Цикл от первой строки до предпоследней.
    For i = 1 To rng.Rows.Count - 1
       
        '2. Проверка, нет ли в текущей строке нечисел. Если есть,
            ' то смысла сравнивать строку с другими нет.
        For j = 1 To rng.Columns.Count
            If IsNumeric(rng.Cells(i, j)) = False Then
                Exit For
            End If
        Next j
       
        ' Если были просмотрены все ячейки текущей строки и не было преджевременного выхода из цикла.
        If j > rng.Columns.Count Then
   
            ' Цикл от текущей строки + 1 до последней строки.
            For ii = i + 1 To rng.Rows.Count
               
                '3. Проверка, нет ли во второй строке нечисел и нулей.
                For j = 1 To rng.Columns.Count
                    If IsNumeric(rng.Cells(ii, j)) = False Then
                        Exit For
                    ElseIf rng.Cells(ii, j) = 0 Then
                        Exit For
                    End If
                Next j
               
                ' Если были просмотрены все ячейки второй строки и не было преджевременного выхода из цикла.
                If j > rng.Columns.Count Then
               
                    '4. Расчёт кэфа для первой пары.
                        ' Такой же кэф должен быть и в остальных парах.
                    kef = rng.Cells(i, 1).Value / rng.Cells(ii, 1).Value
                   
                    '5. Расчёт кэфов в остальных парах и сравнение его с кэфом в переменной "kef".
                    For j = 2 To rng.Columns.Count
                        ' Если текущий кэф другой, то значит строки независимые.
                            ' Остальные пары нет смысла сравнивать.
                        If rng.Cells(i, j) / rng.Cells(ii, j) <> kef Then
                            Exit For
                        End If
                    Next j
                   
                    ' Если не было преждевременного выхода из цикла, значит все кэфы равны.
                    If j > rng.Columns.Count Then
                        '6. Закраска строк.
                        rng.Rows(i).ActiveCell.Interior.Color = 11854022
                        rng.Rows(ii).ActiveCell.Interior.Color = 11854022
                    End If
                       
                End If
               
            Next ii
        End If
    Next i

End Sub

[свернуть]

[nightofpromises]

Спасибо большое.

[Администратор]

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

Чтобы макрос работал, у модуля-класса должно быть имя "ЗависимыеСтроки".

Код для обычного модуля

Sub Макрос()
    Dim ЗависимыеСтроки As ЗависимыеСтроки
    Set ЗависимыеСтроки = New ЗависимыеСтроки
    Set ЗависимыеСтроки.Диапазон = Range("D7:H12")
    ЗависимыеСтроки.ЗакраситьЗависимыеСтроки
    Set ЗависимыеСтроки = Nothing
End Sub

[свернуть]

Код для модуля-класса:

Public Диапазон As Range

Sub ЗакраситьЗависимыеСтроки()
   
    Dim rng As Range, kef As Double
    Dim i As Long, ii As Long, j As Long
   
   
    '1. Присваивание имени "rng" фрагменту, в котором данные.
        ' Так удобнее будет писать и читать код.
    Set rng = Диапазон
   
    ' Цикл от первой строки до предпоследней.
    For i = 1 To rng.Rows.Count - 1
       
        '2. Проверка, нет ли в текущей строке нечисел. Если есть,
            ' то смысла сравнивать строку с другими нет.
        For j = 1 To rng.Columns.Count
            If IsNumeric(rng.Cells(i, j)) = False Then
                Exit For
            End If
        Next j
       
        ' Если были просмотрены все ячейки текущей строки и не было преджевременного выхода из цикла.
        If j > rng.Columns.Count Then
   
            ' Цикл от текущей строки + 1 до последней строки.
            For ii = i + 1 To rng.Rows.Count
               
                '3. Проверка, нет ли во второй строке нечисел и нулей.
                For j = 1 To rng.Columns.Count
                    If IsNumeric(rng.Cells(ii, j)) = False Then
                        Exit For
                    ElseIf rng.Cells(ii, j) = 0 Then
                        Exit For
                    End If
                Next j
               
                ' Если были просмотрены все ячейки второй строки и не было преджевременного выхода из цикла.
                If j > rng.Columns.Count Then
               
                    '4. Расчёт кэфа для первой пары.
                        ' Такой же кэф должен быть и в остальных парах.
                    kef = rng.Cells(i, 1).Value / rng.Cells(ii, 1).Value
                   
                    '5. Расчёт кэфов в остальных парах и сравнение его с кэфом в переменной "kef".
                    For j = 2 To rng.Columns.Count
                        ' Если текущий кэф другой, то значит строки независимые.
                            ' Остальные пары нет смысла сравнивать.
                        If rng.Cells(i, j) / rng.Cells(ii, j) <> kef Then
                            Exit For
                        End If
                    Next j
                   
                    ' Если не было преждевременного выхода из цикла, значит все кэфы равны.
                    If j > rng.Columns.Count Then
                        '6. Закраска строк.
                        rng.Rows(i).ActiveCell.Interior.Color = 11854022
                        rng.Rows(ii).ActiveCell.Interior.Color = 11854022
                    End If
                       
                End If
               
            Next ii
        End If
    Next i

End Sub

[свернуть]