Schlicht und ergreifend so

Option Explicit

Sub Test()
Dim x As Long
Dim strAddi As String
Dim rngSpalte As Range, rngSame As Range, rngA As Range

Application.ScreenUpdating = False
   
   For Each rngSpalte In Range("A1:K11000").Columns
      Set rngSame = Tushar_Mehta(rngSpalte)
      If Not rngSame Is Nothing Then
         For Each rngA In rngSame.Areas
            Select Case rngA.Rows.Count
               Case 2
                  rngA.Interior.Color = RGB(255, 0, 0)
               Case 5
                  rngA.Interior.Color = RGB(0, 0, 255)
               Case Else
                  '
            End Select
         Next rngA
      End If
   Next rngSpalte

   Application.FindFormat.Clear
   Application.ScreenUpdating = True

End Sub


Private Function Tushar_Mehta(Rng As Range) As Range
'frei nach http://www.tushar-mehta.com
Dim FirstCell As Range
Dim CurrCell As Range
Dim rngU As Range

   With Application.FindFormat
      .Clear
      With .Interior
         .Color = RGB(0, 255, 0)
      End With
   End With

   Set FirstCell = Rng.Cells.Find(What:="", After:=Rng.Cells(1), _
      LookIn:=xlFormulas, LookAt:=xlPart, _
      SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False, SearchFormat:=True)
   
   If Not FirstCell Is Nothing Then
      Set CurrCell = FirstCell
      Set rngU = CurrCell
      Do
         Set CurrCell = Rng.Cells.Find(What:="", After:=CurrCell, _
            LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=True)
         If Not CurrCell Is Nothing Then Set rngU = Union(rngU, CurrCell)
      Loop Until CurrCell.Address = FirstCell.Address
      Set Tushar_Mehta = rngU
   End If

End Function