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
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