Не примите за спам. Встречал много вопросов в интернете про перебор путей в графе, не нашел сделанных примеров, сделал сам, решил поделиться. Наверняка кому-нибудь пригодится. Не претендую на изысканность кода, зато работает.


Public Function sBin$(Source)

Dim StrBin As String, lValue As Double


If Source < 0 Then
lValue = (Source And &H7FFF) Or &H8000&
Else: lValue = Source
End If
Do While lValue > 0
StrBin = Chr((lValue Mod 2) + 48) + StrBin
lValue = lValue \ 2
Loop
If StrBin = "" Then sBin = "0" Else sBin = StrBin
End Function
Function min(i, j) As Long
If i > j Then min = j Else min = i
min = min - 1
If min <= 0 Then min = 1
End Function
Sub graf()
nn = 13 ' kol-vo vershin v grafe

Dim i, j As Integer
For i = 1 To 100
For j = 1 To 100
Cells(i, j) = ""
Next
Next
For i = 13 To 1000
Cells(i, 1) = ""
Next i
Cells(1, 2) = 1 'opisanie grafa, 1-rebro est' , "" - rebra net
Cells(2, 3) = 1
Cells(2, 4) = 1
Cells(3, 5) = 1
Cells(4, 5) = 1
Cells(5, 6) = 1
Cells(6, 7) = 1
Cells(7, 8) = 1
Cells(8, 4) = 1
Cells(8, 9) = 1
Cells(9, 10) = 1
Cells(10, 4) = 1
Cells(6, 11) = 1
Cells(9, 12) = 1
Cells(12, 13) = 1
Cells(13, 10) = 1
Cells(12, 10) = 1





Dim konec(1 To 10) As Long

konec(1) = 11 ' tochka vyxoda - konechnyi pyt'

Dim summa(1 To 200) As Long
Dim dopusk(1 To 200) As Long
Dim dopusk_point(1 To 200) As Long
For i = 1 To nn
For j = 1 To nn
If Cells(i, j) = 1 Then summa(i) = summa(i) + 1

Next j
Next i

For i = 1 To nn
For j = 1 To nn

If Cells(i, j) = 1 Then dopusk(j) = dopusk(j) + 1

Next j
Next i

For i = 1 To nn
dopusk_point(i) = dopusk_point(i) + dopusk(i)
Next i
For i = 1 To nn
For j = 1 To nn

If Cells(i, j) = 1 Then
dopusk_point(j) = dopusk_point(j) + dopusk(i)

End If
Next j
Next i


Dim point(1 To 200) As Long
Dim cicle(1 To 200, 1 To 100) As Long
Dim path(1 To 10000000) As String
Dim g(1 To 200, 1 To 200, 1 To 2) As Long
Dim metka(1 To 200, 1 To 200) As Long
Dim kkk As String

Dim st As String
Dim kolvo_reber As Long
'==========================

For i = 1 To nn
For j = 1 To nn
If Cells(i, j) = "1" Then
g(i, j, 1) = CLng(Cells(i, j))
If summa(i) > 1 Then
kolvo_reber = kolvo_reber + 1
g(i, j, 2) = kolvo_reber
End If
Else
g(i, j, 1) = 0
End If
Next j
Next i
'=====================


Dim p As Long

Dim all As Long
all = 2 ^ kolvo_reber - 1

For p = 1 To all ' p=1 - tochka vxoda sBin$(LTrim(Str(2 ^ (nn) - 1)))

st = "1"
kkk = sBin$(LTrim(Str(p)))
Erase metka
Erase cicle
again:

If Len(kkk) < Len(sBin$(LTrim(Str(all)))) Then
kkk = "0" + kkk
GoTo again
End If


For i = 1 To nn
For j = 1 To nn
If g(i, j, 1) = 1 Then
If summa(i) > 1 Then

If Mid(kkk, g(i, j, 2), 1) = 1 Then
metka(i, j) = 1
Else
metka(i, j) = 0 ' 0- rebra net, 1 - rebro est'
End If
Else
If summa(i) = 1 Then metka(i, j) = 1
End If
End If
Next j
Next i
vershina = 1
marker = 0
Erase cicle
Erase point
For i = vershina To nn


If i > 1 And putt = 0 Then Exit For
For j = 2 To nn
putt = 0
If g(i, j, 1) = 1 And metka(i, j) = 1 Then
If summa(i) > 1 Then
marker = i
temp = st
End If
If cicle(i, j) < min(dopusk_point(i), dopusk_point(j)) Then
st = st + "->" + LTrim(Str(j))

cicle(i, j) = cicle(i, j) + 1
point(i) = point(i) + 1
If cicle(i, j) > min(dopusk_point(i), dopusk_point(j)) Then
'If summa(i) > 1 Then cicle(j) = cicle(j) - 1
If point(i) > dopusk_point(i) Then
i = marker - 1
putt = 1
st = temp
Exit For
End If
End If
putt = 1
vershina = j
i = vershina - 1
For kon = 1 To 10
If konec(kon) = 0 Then Exit For
If konec(kon) = j Then ' konechnaya vershina
num_path = num_path + 1
path(num_path) = st 'path finded
GoTo next_path
End If
Next kon
Exit For

End If
End If
Next j
Next i
next_path:
Next p


For i = 1 To num_path
trigger = 0
For j = i + 1 To num_path
If path(i) = path(j) Then
trigger = 1
Exit For
End If
Next j
If trigger = 0 Then
ddd = ddd + 1
Cells(nn + 10 + ddd, 1) = path(i)
End If
Next i
End Sub