Добрый день! возможно кто-то подскажет можно ли написать макрос реализующий определенный алгоритм. С проблемой столкнулся в рамках решения транспортной задачи, а точнее на стадии анализа отклонения от оптимума.
Дана матрица с положительными, отрицательными и пустыми ячейками, например:
A
B
C
D
E
1
41
24
32
-2
42
2
-14
2
47
25
-30
3
23
-1
-17
12
-45
4
-46
-8
-33
5
-36
5
28
-22
18
-46
-38
Необходимо для каждой не пустой ячейки матрицы найти точку "B" в той же строке с противоположным знаком, и с противоположным знаком в том же столбце точку "C", точка "D" с тем же знаком (+,-) что и точка "А" имеет координаты: пересечение солбца точки B и строки точки C После чего сложить сумму A+B+C+D, и ранжировать полученный результат, от большего к меньшему.
Пример: Для А1 есть два варианта: 1) 41 + (-2) + (-14) + 25 = 50 2) 41 + (-2) + (-46) + 5 = -2
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. можно ли как-то отсечь пустые ячейки? (пример прикладываю) ведь они не противоположного значения, а просто пусты
Получился хороший пример для занятий по структурному программированию.
Код
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 раза уменьшить , т.к. от перемены слагаемых сумма не меняется, правильно?
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 значения такие же, но в другой последовательности? МатросНаЗебре, Может быть имеет смысл сравнивать координаты значений, и удалять дубликаты по координатам?
Извиняюсь за неоднозначные догадки, стараюсь учиться.
Предыдущий вариант смотрел только на итоговую сумму. Этот вариант смотрит на координаты ячеек, одинаковые комбинации ячеек не выводятся. 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 Строк для выведения результата должно хватать файл с примером прикладываю
Наглядная демонстрация, как использование переходов может сделать код короче и более понятным (субъективно)
Код из #10
Код
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 GoTo nx1
For x2 = 2 To UBound(arr, 2)
If arr(y1, x2) = "" Then GoTo nx2
If x1 = x2 Then GoTo nx2
If Sgn(arr(y1, x1)) = Sgn(arr(y1, x2)) Then GoTo nx2
For y2 = 2 To UBound(arr, 1)
If arr(y2, x1) = "" Then GoTo nx3
If y1 = y2 Then GoTo nx3
If arr(y2, x2) = "" Then GoTo nx3
If Sgn(arr(y1, x1)) = Sgn(arr(y2, x1)) Then GoTo nx3
If Sgn(arr(y1, x1)) <> Sgn(arr(y2, x2)) Then GoTo nx3
y1m = Application.min(y1, y2)
y2m = Application.max(y1, y2)
x1m = Application.min(x1, x2)
x2m = Application.max(x1, x2)
If dicOut.Exists(Join(Array(y1m, y2m, x1m, x2m), " ")) Then GoTo nx3
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
nx3: Next y2
nx2: Next x2
nx1: Next x1
Next y1
OutArr aOut
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, большое спасибо за демонстрацию, но пустые ячейки все равно алгоритм не пропускает, только когда соберет все варианты начинается отсев... к сожалению поэтому большего размера матрицу например 40 х 40 уже не получится просчитать на комбинации, что видно на примере в #11.
Grantorino, можете обозначить исходную задачу (вариантов транспортных задач достаточно много) Может быть найдется альтернативное решение, в т. ч. через "Поиск решения" или другим способом Опишите исходную задачу, с указанием реальных данных
MCH, изначально имелась транспортная задача классического вида - склады-магазины, она решена симплекс методом (метод потенциалов, он же двойственный симплекс). соответственно имеется оптимальное решение, и факт который случился, их необходимо сопоставить и проанализировать анализ строится на основе нахождения циклов которые используются в методе потенциалов. Для этого я создаю третью матрицу- наложение оптимума на факт(оптимальная матрица - фактическая матрица), получилась матрица которая в прикреплена примере с положительными, отрицательными и пустыми значениями. с помощью этой матрицы и макроса можно удобно найти циклы и определить наиболее весомые из них.
Прошу помощи. пример прикреплен в сообщении 11. При запуске макроса происходит ошибка Runtime error. мне кажется это из-за того, что варианты отсеиваются после того как макрос их все переберёт, вставит (тут видимо и не хватает строк) , а не в момент самого отбора.