Macros to highlight three or more consecutive numbers entered in a set row

[anuptv]

Guys, I would like help in creating an macros to highlight duplicate values by searching in Rows and column in an excel sheet..

the criteria is three consecutive numbers or more...

for example:

20	157	650	43	265	856	48	417	544	250	11	778
56	13	66	139	246	396	697	667	197	127	506	106
231	522	8	87	724	522	210	409	301	968	57	103
928	38	259	182	31	20	157	650	43	583	101	446

the macros must search the excel sheet ( ex B2 to M32) and highlight the underlined letters..

[mana]

You can use "conditional formatting"

Option Explicit

Sub test()
    Dim tbl As Range
    Dim r(1 To 6) As Range
    Dim f(1 To 6) As String
    Dim k As Long
    Dim fc As FormatCondition
    
    Set tbl = Range("B2:M32")
    
    Set r(1) = tbl.Resize(, tbl.Columns.Count - 2)
    Set r(2) = r(1).Offset(, 1)
    Set r(3) = r(1).Offset(, 2)
    
    Set r(4) = tbl.Resize(tbl.Rows.Count - 2)
    Set r(5) = r(4).Offset(1)
    Set r(6) = r(4).Offset(2)
    
    f(1) = "=COUNTIFS(" & r(1).Address(, , xlR1C1) & ",rc," _
                        & r(2).Address(, , xlR1C1) & ",rc[1]," _
                        & r(3).Address(, , xlR1C1) & ",rc[2])>1"
                
    f(2) = "=COUNTIFS(" & r(1).Address(, , xlR1C1) & ",rc[-1]," _
                        & r(2).Address(, , xlR1C1) & ",rc," _
                        & r(3).Address(, , xlR1C1) & ",rc[1])>1"
                 
    f(3) = "=COUNTIFS(" & r(1).Address(, , xlR1C1) & ",rc[-2]," _
                        & r(2).Address(, , xlR1C1) & ",rc[-1]," _
                        & r(3).Address(, , xlR1C1) & ",rc)>1"
                 
        f(4) = "=COUNTIFS(" & r(4).Address(, , xlR1C1) & ",rc," _
                            & r(5).Address(, , xlR1C1) & ",r[1]c," _
                            & r(6).Address(, , xlR1C1) & ",r[2]c)>1"
                    
        f(5) = "=COUNTIFS(" & r(4).Address(, , xlR1C1) & ",r[-1]c," _
                            & r(5).Address(, , xlR1C1) & ",rc," _
                            & r(6).Address(, , xlR1C1) & ",r[1]c)>1"
                     
        f(6) = "=COUNTIFS(" & r(4).Address(, , xlR1C1) & ",r[-2]c," _
                            & r(5).Address(, , xlR1C1) & ",r[-1]c," _
                            & r(6).Address(, , xlR1C1) & ",rc)>1"
                 
    tbl.FormatConditions.Delete
    
    For k = 1 To 6
        Set fc = r(k).FormatConditions.Add(Type:=xlExpression, Formula1:=f(k))
        fc.Font.Underline = True
    Next


End Sub

マナ