Option Explicit
Sub MeineFarbeImKlecks()
Dim Rng As Range
Set Rng = MeinKlecks(ActiveCell)
Call MsgBox(" in der Farbumgebung = " & FarbeImKlecks(ActiveCell, Rng).Address, _
vbInformation, "meine Farbe")
End Sub
Sub FarbklecksUmgebung()
Call MsgBox("Umgebung = " & MeinKlecks(ActiveCell).Address, _
vbInformation, "farbiger Spaltenbereich")
End Sub
Function FarbeImKlecks(myCell As Range, myArea As Range) As Range
Dim c As Range
Set FarbeImKlecks = myCell
For Each c In myArea
If c.Address <> myCell.Address Then
If c.Interior.ColorIndex = myCell.Interior.ColorIndex Then _
Set myCell = Union(c, myCell)
End If
Next c
Set FarbeImKlecks = myCell
End Function
Function MeinKlecks(myCell As Range) As Range
Dim Rng As Range, Flt As Range
Dim x As Long, fst As Long, lst As Long
Set MeinKlecks = myCell
Set Rng = ActiveSheet.Columns(myCell.Column)
fst = Rng.Rows(1).Row
lst = Rng.Rows(Rng.Rows.Count).Row
Application.ScreenUpdating = False
With Rng
.AutoFilter
.AutoFilter Field:=1, Operator:=xlFilterNoFill
Set Flt = .SpecialCells(xlCellTypeVisible)
.AutoFilter
End With
Application.ScreenUpdating = True
If Not Intersect(Flt, myCell) Is Nothing Then
Call MsgBox("Bereich ungültig!", vbCritical, "Abbruch")
Exit Function
End If
For x = Flt.Areas.Count To 1 Step -1
If Flt.Areas(x).Cells(1).Row < myCell.Row Then
On Error Resume Next
fst = Flt.Areas(x).Row + Flt.Areas(x).Rows.Count
lst = Flt.Areas(x + 1).Row - 1
Set MeinKlecks = Range(Cells(fst, myCell.Column), Cells(lst, myCell.Column))
On Error GoTo 0
Exit For
End If
Next x
End Function