Помогите дописать программу.
Нужно реализовать алгоритм/формулу Мезона. Граф задается матрицей смежности. Нужно найти коэффициент передачи графа, для чего находятся контура графа(на изображении Li) и простой путь(P). Контура графа и путь я нашел, дальше нужно определить непересекающиеся контура(не имеющие общих вершин) и посчитать путь,вот в этом проблема
Sub Дерево()
Dim NumVer As Integer
Dim NumAnStr As Integer
'NumStr - номер текущей строки
Dim NumStr As Integer
Dim InvAdr As Integer
NumVer = 1
NumStr = 2
NumAnStr = 1
'Запись 1 номера вершины в таблицу "Дерево"
Sheets(2).Cells(1, 1).Value = 1
Sheets(2).Cells(1, 2).Value = 0
Call IncendVer(NumVer, NumStr, NumAnStr)
'цикла анализа по строкам таблицы
NumAnStr = 2
Do
'выбор следующей вершины
NumVer = Sheets(2).Cells(NumAnStr, 1).Value
'проверка на повторяемость вершин,выявление пути и контура
i = 1
Flag = 0
InvAdr = NumAnStr
'цикл анализа путей по строкам таблицы-обратный ход
Do
InvAdr1 = Sheets(2).Cells(InvAdr, 2).Value
NumVer1 = Sheets(2).Cells(InvAdr, 1).Value
Sheets(2).Cells(NumAnStr, i + 4).Value = NumVer1
InvAdr = InvAdr1
'если на обратном пути встретилась вершина с тем же номером
If NumVer = NumVer1 And i > 1 Then
Flag = 1
Sheets(2).Cells(NumAnStr, 3).Value = "контур"
Sheets(2).Cells(NumAnStr, 4).Value = i - 1
Exit Do
End If
If NumVer > 6 Then Sheets(2).Cells(NumAnStr, 3).Value = "путь"
i = i + 1
'выход из цикла если вершина исток
Loop Until NumVer1 = 1
If Flag = 0 Then
Call IncendVer(NumVer, NumStr, NumAnStr)
End If
NumAnStr = NumAnStr + 1
Loop Until NumStr = NumAnStr
'поиск и удаление повторно выделенных контуров
'составление списка путей и контуров
NumStr = NumStr + 1
NumCirc = 1
EndNumAnStr = NumAnStr
For NumAnStr = 1 To EndNumAnStr
If Sheets(2).Cells(NumAnStr, 3).Value = "контур" Then
Sheets(2).Cells(NumStr, 3).Value = "контур"
Sheets(2).Cells(NumStr, 1).Value = NumCirc
Sheets(2).Cells(NumStr, 2).Value = NumAnStr
LenCirc = Sheets(2).Cells(NumAnStr, 4).Value
Sheets(2).Cells(NumStr, 4).Value = LenCirc
For i = 0 To LenCirc
NumVer = Sheets(2).Cells(NumAnStr, i + 5).Value
Sheets(2).Cells(NumStr, i + 5).Value = NumVer
Next i
NumCirc = NumCirc + 1
NumStr = NumStr + 1
End If
Next NumAnStr
End Sub
Sub IncendVer(NumVer, NumStr, NumAnStr)
'просмотр строки матрицы смежности
For NumCol = 1 To 20
'если элемент матрицы смежности не равен 0
If Sheets(1).Cells(NumVer, NumCol).Value <> 0 Then
'запись номера вершины из матрицы смежности в таблицу "дерево"
Sheets(2).Cells(NumStr, 1).Value = NumCol
'запись обратного адреса в таблицу "дерево"
Sheets(2).Cells(NumStr, 2).Value = NumAnStr
NumStr = NumStr + 1
End If
Next NumCol
End Sub
