Option Explicit
Sub test()
Dim arr, pos, i, j, k, t, n, dic(1)
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
pos = [l1:n1].Value
For i = 1 To UBound(pos, 2)
dic(0)(pos(1, i)) = 1
Next
pos = [a1].CurrentRegion.Value
ReDim arr(UBound(pos, 1) + 1, UBound(pos, 2) + 1)
For i = 1 To UBound(pos, 1)
arr(i, 0) = -1
For j = 1 To UBound(pos, 2)
arr(i, j) = pos(i, j)
Next
arr(i, j) = -1
Next
For i = 0 To UBound(arr, 2)
arr(0, i) = -1
arr(UBound(arr, 1), i) = -1
Next
pos = Array(-1, -1, 0, -1, 1, -1, -1, 0, 1, 0, -1, 1, 0, 1, 1, 1)
ReDim brr(1 To dic(0).Count * 2)
[a1].CurrentRegion.Interior.ColorIndex = xlNone
For i = 1 To UBound(arr, 1) - 1
For j = 1 To UBound(arr, 2) - 1
If dic(0).exists(arr(i, j)) Then
dic(1)(arr(i, j)) = 1
n = 2: brr(1) = i: brr(2) = j
For k = 0 To UBound(pos) Step 2
t = arr(i + pos(k), j + pos(k + 1))
If dic(0).exists(t) And Not dic(1).exists(t) Then
dic(1)(t) = 1: n = n + 2
brr(n - 1) = i + pos(k): brr(n) = j + pos(k + 1)
End If
Next
If n = UBound(brr) Then
For k = 1 To n Step 2
If Cells(brr(k), brr(k + 1)).Interior.Color = vbRed Then Exit For
Next
If k = n + 1 Then
For k = 1 To n Step 2
Cells(brr(k), brr(k + 1)).Interior.Color = vbRed
Next
End If
End If
n = 0: dic(1).RemoveAll
End If
Next
Next
End Sub |
楼主: lsdongjh
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-2-21 19:00
