查找超过10次以上的连续序号并标记颜色

代码如下：

Sub Macro1()
    Dim arr, brr(), rng As Range
    Dim lr As Long, i As Long, m As Integer
    lr = Range("a65536").End(xlUp).Row
    ReDim brr(1 To lr + 1)
    arr = Range("a1:a" & lr + 1)
    With CreateObject("VBScript.RegExp")
        .Pattern = "(\d{1,8})"
         For i = 1 To [a65536].End(xlUp).Row
           If .test(arr(i, 1)) Then brr(i) = .Execute(arr(i, 1))(0)
         Next
     End With
    Columns(1).Interior.ColorIndex = xlNone
    For i = 1 To lr
        m = i
        Set rng = Cells(i, 1)
        Do
           m = m + 1
           If Val(brr(m - 1)) + 1 <> Val(brr(m)) Then Exit Do
        Loop
        If m - i > 10 Then
            Range(Cells(i, 1), Cells(m - 1, 1)).Interior.ColorIndex = 6
            i = m
        End If
    Next
End Sub

操作方法：工具-宏-录制新宏-打开宏-编辑-复制代码-宏-执行