Определить, можно ли попасть по дорогам из l-того пункта в m-ый

Option Explicit
 
Sub Main()
Dim n As Byte, Sha As Shape, Routes(), p1%, p2%, Steps%, Punkt(10) As Range, R_save()
ReDim Preserve R_save(9) 'макс. кол-во движений
 
[A1:K10].Clear
For Each Sha In ActiveSheet.Shapes 'удалить все дороги
   Sha.Delete
Next
Columns("A:M").ColumnWidth = 2
Coordinates Punkt() 'получаем координаты пунктов
 
'Заранее заданные дороги для теста
'==== закомментировать этот блок ===
[L1:L9] = Application.Transpose(Array(1, 2, 5, 7, 10, 3, 10, 1, 8))
[M1:M9] = Application.Transpose(Array(2, 6, 8, 9, 7, 8, 9, 8, 10))
'=================================
 
For n = 1 To 10 'отображаем пункты
  Punkt(n) = n
  Punkt(n).Font.Bold = True
Next
 
Routes = Range("L1", [M1].End(xlDown)) 'получаем дороги с листа
For n = 1 To UBound(Routes) 'рисуем дороги
  Draw_Route Punkt(Routes(n, 1)), Punkt(Routes(n, 2))
Next
 
p1 = CInt(InputBox("Введите № пункта А", , 10))
p2 = CInt(InputBox("Введите № пункта Б", , 6))
If p1 = p2 Then MsgBox "Уже приехали!": Exit Sub
 
R_save(0) = p1 'Steps=0
Find_Way p1, p2, Routes(), R_save(), Steps
 
If Steps = 0 Then MsgBox "Дорога не найдена!": Exit Sub
ReDim Preserve R_save(Steps)
For n = 0 To Steps
  Punkt(R_save(n)).Interior.Color = vbYellow
Next
MsgBox Join(R_save, " -> "), , "Будем ехать так ..."
 
End Sub
 
Private Sub Find_Way(ByRef p1%, ByVal p2%, Routes(), R_save(), Steps%)
Dim n As Byte, R_new%, V
 
For n = 1 To UBound(Routes)
  If p1 = p2 Or R_save(Steps) = p2 Then Exit For 'выходим из рекурсии
  R_new = 0
  If Routes(n, 1) = p1 Then 'ищем любую связку пути в массиве
    R_new = Routes(n, 2) 'нашли - отправляемся туда
    ElseIf Routes(n, 2) = p1 Then 'проверка зеркально
      R_new = Routes(n, 1)
  End If
  
  If R_new <> 0 Then 'нашли путь
    For Each V In R_save 'защита от зацикливания
      If R_new = V Then 'а здесь мы уже были
        R_new = 0: Routes(n, 1) = 0: Routes(n, 2) = 0: Exit For 'стираем дорогу
      End If
    Next
  End If
  
  If R_new <> 0 Then 'едем в другую деревню
    Steps = Steps + 1
    R_save(Steps) = R_new 'записываем трекинг на GPS
    Find_Way R_new, p2, Routes(), R_save(), Steps 'рекурсия (ищем как бы проехать от новой деревни)
  End If
Next
 
If p1 <> p2 And R_save(Steps) <> p2 Then
  If Steps <> 0 Then 'если не вернулись к разбитому корыту
     R_save(Steps) = 0 'стираем эпизод
     Steps = Steps - 1 'и едем обратно в предыдущий пункт
  End If
End If
 
End Sub
 
Private Sub Coordinates(Punkt() As Range)  'пингуем пункты
Set Punkt(1) = [E3]: Set Punkt(2) = [G3]
Set Punkt(3) = [C4]: Set Punkt(4) = [I4]
Set Punkt(5) = [B6]: Set Punkt(6) = [J6]
Set Punkt(7) = [C8]: Set Punkt(8) = [I8]
Set Punkt(9) = [E9]: Set Punkt(10) = [G9]
End Sub
 
Private Sub Draw_Route(ByVal RouteA As Range, ByVal RouteB As Range) 'уроки рисования
Dim Cx!, Cy!
Cx = [B2].Left / 2: Cy = [B2].Top / 2 'средина ячейки
ActiveSheet.Shapes.AddLine(RouteA.Left + Cx, RouteA.Top + Cy, RouteB.Left + Cx, RouteB.Top + Cy).Select
End Sub

Private Minc(1 To 10, 1 To 10) As Integer   ' Матрица смежности
Private Chk(1 To 10)              As Integer   ' массив для отметки
Private flg                            As Boolean  ' Флаг "путь найден"
 
Sub Init()  '::: Инициализация 
 
Dim i as integer
Dim j as integer
 
    For i=1 to 10
         Chk[i]=0
         For j=1 to 10
              Minc(i,j)=0
         Next j
    Next i
 
    Minc(1, 5) = 1
    Minc(5, 1) = 1
 
    Minc(2, 5) = 1
    Minc(5, 2) = 1
 
    Minc(3, 5) = 1
    Minc(5, 3) = 1
 
    Minc(6, 5) = 1
    Minc(5, 6) = 1
 
    Minc(6, 7) = 1
    Minc(7, 6) = 1
 
    Minc(4, 5) = 1
    Minc(5, 4) = 1
 
    Minc(4, 8) = 1    '!!!!
    Minc(8, 4) = 1    '!!!!
 
    Minc(9, 8) = 1
    Minc(8, 9) = 1
 
    Minc(8, 10) = 1
    Minc(10, 8) = 1
 
    flg = False
 
End Sub
 
Sub DFS(n As Integer, m As Integer)  '::: Обход в глубину с "отлавливанием" вершины m
 
Dim i As Integer
 
    If flg Then Exit Sub   '::: Если вершина уже встретилась...
 
    Chk(n) = 1
    
    For i = 1 To 10
    
        If (Minc(i, n) <> 0) And (Chk(i) = 0) Then
           
           If i = m Then
              flg = True
              Exit Sub
           End If
           
           DFS i, m
           
        End If
        
    Next i
 
End Sub
 
Sub Start()  '::: Стартовая процедура
 
    Init
 
    DFS 1, 10
 
    If flg Then
       Debug.Print "Путь существует"
    Else
       Debug.Print "Путь не существует"
    End If
 
End Sub

R_save(Steps) = № пункта

Chk(n) = 1

Private Minc(1 To 10, 1 To 10) As Integer
Private Chk(1 To 10)           As Integer
Private flg                    As Boolean
Private Path                   As String   '::: Строка пути
 
Sub Init()
 
Dim i As Integer
Dim j As Integer
 
    For i = 1 To 10
    
        Chk(i) = 0
        
        For j = 1 To 10
            Minc(i, j) = 0
        Next j
        
    Next i
 
    Minc(1, 5) = 1
    Minc(5, 1) = 1
 
    Minc(2, 5) = 1
    Minc(5, 2) = 1
 
    Minc(3, 5) = 1
    Minc(5, 3) = 1
 
    Minc(6, 5) = 1
    Minc(5, 6) = 1
 
    Minc(6, 7) = 1
    Minc(7, 6) = 1
 
    Minc(4, 5) = 1
    Minc(5, 4) = 1
 
    'Minc(4, 8) = 1
    'Minc(8, 4) = 1
 
    Minc(9, 8) = 1
    Minc(8, 9) = 1
 
    Minc(8, 10) = 1
    Minc(10, 8) = 1
 
    flg = False
 
    Path = ""
 
End Sub
 
Sub DFS(n As Integer, m As Integer)
 
Dim i As Integer
 
    If flg Then
       Exit Sub
    End If
 
    Chk(n) = 1
    
    Path = Path & ";" & CStr(n)
    
    For i = 1 To 10
    
        If (Minc(i, n) <> 0) And (Chk(i) = 0) Then
           
           If i = m Then
              flg = True
              Debug.Print Path & ";" & CStr(m) '::: Печать пути
              Exit Sub
           End If
           
           DFS i, m
           
           k% = InStrRev(Path, ";")
           
           Path = Left$(Path, (k% - 1))
                      
        End If
        
    Next i
 
End Sub
 
Sub Start()
 
    Init
 
    DFS 7, 10
 
    If flg Then
       Debug.Print "Путь найден"
    Else
       Debug.Print "Путь не существует"
    End If
 
End Sub