Option Explicit
Dim n, c, w, h
Sub test()
Dim i
Cells.Interior.ColorIndex = xlNone
n = 9 '连续
c = 24 '列号
w = 24 '宽
h = 13 '高
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row Step 17
Call test2(i)
Call test3(i)
Call test4(i)
Next i
End Sub
'从上到下
Sub test2(x)
Dim i, j, Rng As Range
For j = 1 To w
For i = 1 To h - n + 1
Set Rng = Cells(x + i - 1, w + j - 1).Resize(n)
If Application.CountA(Rng) = n Then Rng.Interior.ColorIndex = 6
Next i
Next j
End Sub
'从左下到右上
Sub test3(x)
Dim i, j, k, Rng As Range, addr$
For j = c To c + w - 1
For i = x + h - 1 To x + n - 1 Step -1
'''''''''''''''''''''''''''''''''''''''''''''
addr = ""
For k = 1 To n
Set Rng = Cells(i, j)(-1 * k + 2, k)
If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
Next k
addr = Mid(addr, 2)
If k > n Then Range(addr).Interior.ColorIndex = 3
'''''''''''''''''''''''''''''''''''''''''''''
Next i
Next j
End Sub
'从右下到左上
Sub test4(x)
Dim i, j, k, Rng As Range, addr$
For j = c + w - 1 To c Step -1
For i = x + h - 1 To x + n - 1 Step -1
'''''''''''''''''''''''''''''''''''''''''''''
addr = ""
For k = 1 To n
Set Rng = Cells(i, j)(-1 * k + 2, -1 * k + 2)
If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
Next k
addr = Mid(addr, 2)
If k > n Then Range(addr).Interior.ColorIndex = 4
'''''''''''''''''''''''''''''''''''''''''''''
Next i
Next j
End Sub
2.rar
(140.2 KB, 下载次数: 7)