VBA已解决

lwwy1981

第一个简易迷宫我已经写好了,题目要求参考简易迷宫来写中等迷宫,中等迷宫实在是没有思路,有偿求助,微信QQ同号55444524

lwwy1981

有偿求助

microyip

你不是已经做出来了吗？还有偿什么？

时间的音符

..............................

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dx = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    [i8] = 0
    d([i8].Address) = 0
l1:
    If d.Count <> 0 Then
        str1 = d.keys()(0)
        x = d(str1)
        dx.RemoveAll
        If Range(str1).Offset(1).Interior.ColorIndex = 6 And Len(Range(str1).Offset(1)) = 0 Then
            dx(Range(str1).Offset(1).Address) = x + 1
            Range(str1).Offset(1) = x + 1
        Else
            If Range(str1).Offset(1).Interior.ColorIndex = 3 And Len(Range(str1).Offset(1)) = 0 Then
                Range(str1).Offset(1) = x + 1
            End If
        End If
        
        If Range(str1).Offset(-1).Interior.ColorIndex = 6 And Len(Range(str1).Offset(-1)) = 0 Then
            dx(Range(str1).Offset(-1).Address) = x + 1
            Range(str1).Offset(-1) = x + 1
        Else
            If Range(str1).Offset(-1).Interior.ColorIndex = 3 And Len(Range(str1).Offset(-1)) = 0 Then
                Range(str1).Offset(-1) = x + 1
            End If
        End If
        If Range(str1).Offset(0, 1).Interior.ColorIndex = 6 And Len(Range(str1).Offset(0, 1)) = 0 Then
            dx(Range(str1).Offset(0, 1).Address) = x + 1
            Range(str1).Offset(0, 1) = x + 1
        Else
            If Range(str1).Offset(0, 1).Interior.ColorIndex = 3 And Len(Range(str1).Offset(0, 1)) = 0 Then
                Range(str1).Offset(0, 1) = x + 1
            End If
        End If
        If Range(str1).Offset(0, -1).Interior.ColorIndex = 6 And Len(Range(str1).Offset(0, -1)) = 0 Then
            dx(Range(str1).Offset(0, -1).Address) = x + 1
            Range(str1).Offset(0, -1) = x + 1
        Else
            If Range(str1).Offset(0, -1).Interior.ColorIndex = 3 And Len(Range(str1).Offset(0, -1)) = 0 Then
                Range(str1).Offset(0, -1) = x + 1
            End If
        End If
        d.Remove str1
        If dx.Count <> 0 Then
            For Each k In dx.keys
                d(k) = dx(k)
            Next k
        End If
        GoTo l1
    End If
    Application.ScreenUpdating = True
End Sub

liulang0808

模拟要给供参考四个if语句可以简化操作的

micch

解决了，do一下

1. Sub MMaze()
   
2.         Set Area = Range("df_2")
   
3.         Area.ClearContents
   
4.         Dim rng As Range, rngn As Range
   
5.         Set rng = Area(1)
   
6.         Set YelwRng = rng
   
7.         'Application.ScreenUpdating = False
   
8.         Do
   
9.                     Set YelwRng = CutRng(YelwRng, rng) 'YelwRng 中减去 rng
   
10.                     Do
    
11.                             Set rngn = GetYelw(rng) '找到相邻的4个单元格中黄色单元格
    
12.                             If rngn Is Nothing Then Exit Do
    
13.                             rngn = rng.Value + 1
    
14.                             Set rng = rngn
    
15.                             Call doeve 'doevents 停顿
    
16.                     Loop
    
17.                     If YelwRng Is Nothing Then Exit Do
    
18.                     Set rng = YelwRng(1)
    
19.         Loop
    
20.         'Application.ScreenUpdating = True
    
21. End Sub

复制代码

一把小刀闯天下

'挺奇怪迷宫怎么还有多个出个的，，，

Option Explicit

Sub test()
  Dim x, y, pos
  x = 8: y = 9 '蓝色起点坐标
  pos = Array(-1, 0, 0, -1, 1, 0, 0, 1)
  Sheets("Medium").Activate
  Cells.ClearContents
  Call dfs(x, y, 0, pos)
End Sub

Function dfs(x, y, n, pos)
  Dim i, p
  For i = 0 To UBound(pos) Step 2
    If (Cells(x + pos(i), y + pos(i + 1)).Interior.Color = vbYellow Or Cells(x + pos(i), y + pos(i + 1)).Interior.Color _
    = vbRed) And Len(Cells(x + pos(i), y + pos(i + 1))) = 0 Then
      p = n: n = n + 1
      Cells(x + pos(i), y + pos(i + 1)) = n
      Call dfs(x + pos(i), y + pos(i + 1), n, pos)
      n = p
    End If
  Next
End Function