in welchen Bereichen befindet sich die akt. Zelle

Sub BereicheErmitteln()
Dim myNames() As String
Dim solutNames() As String
Dim i As Integer
Dim j As Integer
Dim EinName As Name
Dim bereich1 As Range
Dim bereich2 As Range
Dim isect As Range
Dim Blatt As String
Dim Blatt1 As String
i = 0: j = 0
For Each EinName In Application.Names
ReDim Preserve myNames(i)
myNames(i) = EinName.Name
i = i + 1
Next
Blatt = ActiveSheet.Name
Set bereich1 = ActiveCell
For i = LBound(myNames) To UBound(myNames)
If myNames(i) <> "" Then
Set bereich2 = Application.Range(Range(myNames(i)).Address)
Application.Goto Reference:=myNames(i)
Blatt1 = ActiveSheet.Name
Set isect = Application.Intersect(bereich1, bereich2)
If isect Is Nothing Then
Else
If (Blatt = Blatt1) Then
ReDim Preserve solutNames(j)
solutNames(j) = myNames(i)
j = j + 1
End If
End If
End If
Next
'   MsgBox ""
End Sub