'没做起始点判断,效率差了一点,,,
Option Explicit
Dim max, cnt, list(1 To 100)
Sub test()
Dim arr, i, j, k, pos, t
pos = Array(1, 1, 1, 0, -1, 0, 1, 1) '左下、下、右下、左
arr = [b2].Resize(11, 11)
max = 0: cnt = 0
For i = 2 To UBound(arr, 1) - 1
For j = 2 To UBound(arr, 2) - 1
If Len(arr(i, j)) Then
For k = 0 To 3
Call rec(arr, i, j, pos(k), pos(k + 4), 0, i & "," & j)
Next
End If
Next j, i
Cells.Font.Color = vbBlack
If max > 0 Then
For i = 1 To cnt
t = Split(list(i), ",")
For j = 0 To UBound(t) - 2 Step 2
Cells(Val(t(j)) + 1, Val(t(j + 1)) + 1).Font.Color = vbRed
Next j, i
End If
End Sub
Function rec(arr, x, y, a, b, n, s)
If Len(arr(x, y)) = 0 Then
If max < n Then
max = n: cnt = 1: list(cnt) = s
ElseIf max = n Then
cnt = cnt + 1: list(cnt) = s
End If
Else
Call rec(arr, x + a, y + b, a, b, n + 1, s & "," & x + a & "," & y + b)
End If
End Function |