Страницы: 1
RSS
Найти комбинацию в матрице
 
Добрый день! возможно кто-то подскажет можно ли написать макрос реализующий определенный алгоритм.
С проблемой столкнулся в рамках решения транспортной задачи, а точнее на стадии анализа отклонения от оптимума.

Дана матрица с положительными, отрицательными и пустыми ячейками, например:
ABCDE
1412432-242
2-1424725-30
323-1-1712-45
4-46-8-335-36
528-2218-46-38
Необходимо для каждой не пустой ячейки матрицы найти точку "B" в той же строке с противоположным знаком, и с противоположным знаком в том же столбце точку "C", точка "D" с тем же знаком (+,-) что и точка "А" имеет координаты: пересечение солбца точки B и строки точки C
После чего сложить сумму A+B+C+D, и ранжировать полученный результат, от большего к меньшему.

Пример: Для А1 есть два варианта:
1) 41 + (-2) + (-14) + 25 = 50
2) 41 + (-2) + (-46) + 5 = -2
Изменено: Grantorino - 21.01.2020 12:17:50
 
Код
Sub Main()
    Dim arr As Variant
    arr = Range("A1:F6")
    
    Dim aOut As Variant
    ReDim aOut(1 To UBound(arr, 1) * UBound(arr, 2) * (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 5)
    Dim yOut As Long
    yOut = 1
    
    Dim y1 As Long
    Dim x1 As Integer
    Dim y2 As Long
    Dim x2 As Integer
    For y1 = 2 To UBound(arr, 1)
        For x1 = 2 To UBound(arr, 2)
            For x2 = 2 To UBound(arr, 2)
                If x1 <> x2 Then
                    If Sgn(arr(y1, x1)) <> Sgn(arr(y1, x2)) Then
                        For y2 = 2 To UBound(arr, 1)
                            If y1 <> y2 Then
                                If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x1)) Then
                                    If Sgn(arr(y1, x1)) = Sgn(arr(y2, x2)) Then
                                        Debug.Print arr(y1, x1)
                                        aOut(yOut, 2) = arr(y1, x1)
                                        aOut(yOut, 3) = arr(y1, x2)
                                        aOut(yOut, 4) = arr(y2, x1)
                                        aOut(yOut, 5) = arr(y2, x2)
                                        aOut(yOut, 1) = aOut(yOut, 2) + aOut(yOut, 3) + aOut(yOut, 4) + aOut(yOut, 5)
                                        yOut = yOut + 1
                                    End If
                                End If
                            End If
                        Next
                    End If
                End If
            Next
        Next
    Next
    
    OutArr aOut
End Sub

Sub OutArr(aOut As Variant)
    Dim r As Range
    Set r = Range("H1").Resize(UBound(aOut, 1), UBound(aOut, 2))
    r.Value = aOut
    SortRange r
End Sub

Sub SortRange(r As Range)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range(r.Address(0, 0))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
МатросНаЗебре,большое спасибо Вам!

Если я все верно понял, то для матрицы иного размера (например 5*9) достаточно изменить arr.
можно ли как-то отсечь пустые ячейки? (пример прикладываю) ведь они не противоположного значения, а просто пусты
Изменено: Grantorino - 21.01.2020 14:42:28
 
Получился хороший пример для занятий по структурному программированию.
Код
Sub Main()
    Dim arr As Variant
    arr = Range("A1:F6")
    
    Dim aOut As Variant
    ReDim aOut(1 To UBound(arr, 1) * UBound(arr, 2) * (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 5)
    Dim yOut As Long
    yOut = 1
    
    Dim y1 As Long
    Dim x1 As Integer
    Dim y2 As Long
    Dim x2 As Integer
    For y1 = 2 To UBound(arr, 1)
        For x1 = 2 To UBound(arr, 2)
            If arr(y1, x1) <> "" Then
                For x2 = 2 To UBound(arr, 2)
                    If arr(y1, x2) <> "" Then
                        If x1 <> x2 Then
                            If Sgn(arr(y1, x1)) <> Sgn(arr(y1, x2)) Then
                                For y2 = 2 To UBound(arr, 1)
                                    If arr(y2, x1) <> "" Then
                                        If y1 <> y2 Then
                                            If arr(y2, x2) <> "" Then
                                                If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x1)) Then
                                                    If Sgn(arr(y1, x1)) = Sgn(arr(y2, x2)) Then
                                                        aOut(yOut, 2) = arr(y1, x1)
                                                        aOut(yOut, 3) = arr(y1, x2)
                                                        aOut(yOut, 4) = arr(y2, x1)
                                                        aOut(yOut, 5) = arr(y2, x2)
                                                        aOut(yOut, 1) = aOut(yOut, 2) + aOut(yOut, 3) + aOut(yOut, 4) + aOut(yOut, 5)
                                                        yOut = yOut + 1
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                Next
                            End If
                        End If
                    End If
                Next
            End If
        Next
    Next
    
    OutArr aOut
End Sub
Sub OutArr(aOut As Variant)
    Dim r As Range
    Set r = Range("H1").Resize(UBound(aOut, 1), UBound(aOut, 2))
    r.Value = aOut
    SortRange r
End Sub
Sub SortRange(r As Range)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range(r.Address(0, 0))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
МатросНаЗебре, Очень интересный макрос еще раз благодарю! А список выводимый можно ведь еще в 4 раза уменьшить , т.к. от перемены слагаемых сумма не меняется, правильно?
Изменено: Grantorino - 21.01.2020 15:16:31
 
Код
Sub Main()
    Dim arr As Variant
    arr = Range("A1:F6")
    
    Dim aOut As Variant
    ReDim aOut(1 To UBound(arr, 1) * UBound(arr, 2) * (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 5)
    Dim yOut As Long
    yOut = 1
    
    Dim dicOut As Object
    Set dicOut = CreateObject("Scripting.Dictionary")
    
    Dim y1 As Long
    Dim x1 As Integer
    Dim y2 As Long
    Dim x2 As Integer
    For y1 = 2 To UBound(arr, 1)
        For x1 = 2 To UBound(arr, 2)
            If arr(y1, x1) <> "" Then
                For x2 = 2 To UBound(arr, 2)
                    If arr(y1, x2) <> "" Then
                        If x1 <> x2 Then
                            If Sgn(arr(y1, x1)) <> Sgn(arr(y1, x2)) Then
                                For y2 = 2 To UBound(arr, 1)
                                    If arr(y2, x1) <> "" Then
                                        If y1 <> y2 Then
                                            If arr(y2, x2) <> "" Then
                                                If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x1)) Then
                                                    If Sgn(arr(y1, x1)) = Sgn(arr(y2, x2)) Then
                                                        If Not dicOut.Exists(arr(y1, x1) + arr(y1, x2) + arr(y2, x1) + arr(y2, x2)) Then
                                                            aOut(yOut, 2) = arr(y1, x1)
                                                            aOut(yOut, 3) = arr(y1, x2)
                                                            aOut(yOut, 4) = arr(y2, x1)
                                                            aOut(yOut, 5) = arr(y2, x2)
                                                            aOut(yOut, 1) = aOut(yOut, 2) + aOut(yOut, 3) + aOut(yOut, 4) + aOut(yOut, 5)
                                                            dicOut.Item(aOut(yOut, 1)) = 0
                                                            yOut = yOut + 1
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                Next
                            End If
                        End If
                    End If
                Next
            End If
        Next
    Next
    
    OutArr aOut
End Sub

Sub OutArr(aOut As Variant)
    Dim r As Range
    Set r = Range("H1").Resize(UBound(aOut, 1), UBound(aOut, 2))
    r.Value = aOut
    SortRange r
End Sub

Sub SortRange(r As Range)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range(r.Address(0, 0))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Таким способом макрос удаляет не выводит результаты с одинаковой итоговой суммой или только те результаты в которых 4 значения такие же, но в другой последовательности?
МатросНаЗебре, Может быть имеет смысл сравнивать координаты значений, и удалять дубликаты по координатам?

Извиняюсь за неоднозначные догадки, стараюсь учиться.
Изменено: Grantorino - 22.01.2020 19:55:05
 
Предыдущий вариант смотрел только на итоговую сумму. Этот вариант смотрит на координаты ячеек, одинаковые комбинации ячеек не выводятся.
PS Не цитируйте сообщение целиком.
Код
Sub Main()
    Dim arr As Variant
    arr = Range("A1:F6")
    
    Dim aOut As Variant
    ReDim aOut(1 To UBound(arr, 1) * UBound(arr, 2) * (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 5)
    Dim yOut As Long
    yOut = 1
    
    Dim dicOut As Object
    Set dicOut = CreateObject("Scripting.Dictionary")
    
    Dim y1m As Long
    Dim x1m As Integer
    Dim y2m As Long
    Dim x2m As Integer
    
    Dim y1 As Long
    Dim x1 As Integer
    Dim y2 As Long
    Dim x2 As Integer
    For y1 = 2 To UBound(arr, 1)
        For x1 = 2 To UBound(arr, 2)
            If arr(y1, x1) <> "" Then
                For x2 = 2 To UBound(arr, 2)
                    If arr(y1, x2) <> "" Then
                        If x1 <> x2 Then
                            If Sgn(arr(y1, x1)) <> Sgn(arr(y1, x2)) Then
                                For y2 = 2 To UBound(arr, 1)
                                    If arr(y2, x1) <> "" Then
                                        If y1 <> y2 Then
                                            If arr(y2, x2) <> "" Then
                                                If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x1)) Then
                                                    If Sgn(arr(y1, x1)) = Sgn(arr(y2, x2)) Then
'                                                        If arr(y1, x1) + arr(y1, x2) + arr(y2, x1) + arr(y2, x2) = 50 Then
'                                                            Union(Cells(y1, x1), Cells(y1, x2), Cells(y2, x1), Cells(y2, x2)).Select
'                                                            Stop
'                                                        End If
                                                        y1m = Application.Min(y1, y2)
                                                        y2m = Application.Max(y1, y2)
                                                        x1m = Application.Min(x1, x2)
                                                        x2m = Application.Max(x1, x2)
                                                        If Not dicOut.Exists(Join(Array(y1m, y2m, x1m, x2m), " ")) Then
                                                            aOut(yOut, 2) = arr(y1, x1)
                                                            aOut(yOut, 3) = arr(y1, x2)
                                                            aOut(yOut, 4) = arr(y2, x1)
                                                            aOut(yOut, 5) = arr(y2, x2)
                                                            aOut(yOut, 1) = aOut(yOut, 2) + aOut(yOut, 3) + aOut(yOut, 4) + aOut(yOut, 5)
                                                            dicOut.Item(Join(Array(y1m, y2m, x1m, x2m), " ")) = 0
                                                            yOut = yOut + 1
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                Next
                            End If
                        End If
                    End If
                Next
            End If
        Next
    Next
    
    OutArr aOut
End Sub
'--------------------------------------------------------
Sub OutArr(aOut As Variant)
    Dim r As Range
    Set r = Range("H1").Resize(UBound(aOut, 1), UBound(aOut, 2))
    r.Value = aOut
    SortRange r
End Sub
'--------------------------------------------------------
Sub SortRange(r As Range)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range(r.Address(0, 0))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
МатросНаЗебре, добрый день

Для того чтобы выводились в списке рядом с цифрами их координаты необходимо добавить переменные или просто вывести х и у ?
 
Можно и без дополнительных переменных.
Код
Sub Main()
    Dim arr As Variant
    arr = Range("A1:F6")
    
    Dim aOut As Variant
    ReDim aOut(1 To UBound(arr, 1) * UBound(arr, 2) * (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 9)
    Dim yOut As Long
    yOut = 1
    
    Dim dicOut As Object
    Set dicOut = CreateObject("Scripting.Dictionary")
    
    Dim y1m As Long
    Dim x1m As Integer
    Dim y2m As Long
    Dim x2m As Integer
    
    Dim y1 As Long
    Dim x1 As Integer
    Dim y2 As Long
    Dim x2 As Integer
    For y1 = 2 To UBound(arr, 1)
        For x1 = 2 To UBound(arr, 2)
            If arr(y1, x1) <> "" Then
                For x2 = 2 To UBound(arr, 2)
                    If arr(y1, x2) <> "" Then
                        If x1 <> x2 Then
                            If Sgn(arr(y1, x1)) <> Sgn(arr(y1, x2)) Then
                                For y2 = 2 To UBound(arr, 1)
                                    If arr(y2, x1) <> "" Then
                                        If y1 <> y2 Then
                                            If arr(y2, x2) <> "" Then
                                                If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x1)) Then
                                                    If Sgn(arr(y1, x1)) = Sgn(arr(y2, x2)) Then
'                                                        If arr(y1, x1) + arr(y1, x2) + arr(y2, x1) + arr(y2, x2) = 50 Then
'                                                            Union(Cells(y1, x1), Cells(y1, x2), Cells(y2, x1), Cells(y2, x2)).Select
'                                                            Stop
'                                                        End If
                                                        y1m = Application.Min(y1, y2)
                                                        y2m = Application.Max(y1, y2)
                                                        x1m = Application.Min(x1, x2)
                                                        x2m = Application.Max(x1, x2)
                                                        If Not dicOut.Exists(Join(Array(y1m, y2m, x1m, x2m), " ")) Then
                                                            aOut(yOut, 2) = arr(y1, x1)
                                                            aOut(yOut, 3) = arr(y1, x2)
                                                            aOut(yOut, 4) = arr(y2, x1)
                                                            aOut(yOut, 5) = arr(y2, x2)
                                                            aOut(yOut, 1) = aOut(yOut, 2) + aOut(yOut, 3) + aOut(yOut, 4) + aOut(yOut, 5)
                                                            aOut(yOut, 6) = arr(1, x1) & "-" & arr(y1, 1)
                                                            aOut(yOut, 7) = arr(1, x2) & "-" & arr(y1, 1)
                                                            aOut(yOut, 8) = arr(1, x1) & "-" & arr(y2, 1)
                                                            aOut(yOut, 9) = arr(1, x2) & "-" & arr(y2, 1)
                                                            
                                                            dicOut.Item(Join(Array(y1m, y2m, x1m, x2m), " ")) = 0
                                                            yOut = yOut + 1
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                Next
                            End If
                        End If
                    End If
                Next
            End If
        Next
    Next
    
    OutArr aOut
End Sub
 
Добрый день
Подскажите, если выбрать матрицу например 10*100 то возникает ошибка Runtime error 1004 application difined or option defined
Строк для выведения результата должно хватать
файл с примером прикладываю
Изменено: Grantorino - 23.01.2020 10:30:56
 
Может быть кто-то может подсказать как побороть ошибку при использовании макроса на матрице из #11?  
Изменено: Grantorino - 08.06.2020 11:47:40
 
Наглядная демонстрация, как использование переходов может сделать код короче и более понятным (субъективно)
Код из #10
Изменено: Jack Famous - 03.06.2020 13:33:22
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, большое спасибо за демонстрацию, но пустые ячейки все равно алгоритм не пропускает, только когда соберет  все варианты начинается отсев...  к сожалению поэтому большего размера матрицу например 40 х 40 уже не получится просчитать на комбинации, что видно на примере в #11.
 
Grantorino, можете обозначить исходную задачу (вариантов транспортных задач достаточно много)
Может быть найдется альтернативное решение, в т. ч. через "Поиск решения" или другим способом
Опишите исходную задачу, с указанием реальных данных
 
MCH, изначально имелась транспортная задача классического вида - склады-магазины, она решена симплекс методом (метод потенциалов, он же двойственный симплекс). соответственно имеется оптимальное решение, и факт который случился, их необходимо сопоставить и проанализировать анализ строится на основе нахождения циклов которые используются в методе потенциалов. Для этого я создаю третью матрицу- наложение оптимума на факт(оптимальная матрица - фактическая матрица), получилась матрица которая в прикреплена примере с положительными, отрицательными и пустыми значениями. с помощью этой матрицы и макроса можно удобно найти циклы и определить наиболее весомые из них.
Изменено: Grantorino - 03.06.2020 16:38:40
 
Прошу помощи. пример прикреплен в сообщении 11. При запуске макроса происходит ошибка Runtime error. мне кажется это из-за того, что варианты отсеиваются после того как макрос их все переберёт, вставит (тут видимо и не хватает строк) , а не в момент самого отбора.
Страницы: 1
Наверх