Markierte Zellen & Ergebnisse anzeigen

[Solevita]

Danke für die Anpassungen. Ich würde gern nur die Sperre für die obere Tabelle einfügen also rng_1 & rng_2 so wie es in deiner Beispieltabelle funktioniert. Es muss mir möglich sein in die kleine Tabelle unten rechts rein zukommen um die Ergebnisse mit Strg+C kopieren zu können. Der Cursor muss auch nicht von überall zurück auf B23 springen, mir war nur wichtig das er nach der Eingabe in B23 bleibt, bzw. wieder dahin zurück springt, was gut funktionierte.

Die Befehle "protect" und "unprotect" an den selben stellen wie bei dir im Code funktionieren bei mir leider nicht ohne Fehler. Gibt es eine Möglichkeit sie in diesem Code zu implementieren ohne die Funktionen zu verändern/beeinträchtigen?

Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B24")) Is Nothing Then
        Application.EnableEvents = False
        Me.Cells(Target.Row - 1, Target.Column).Select
        Application.EnableEvents = True
    End If
    Dim iZeile As Range, iSpalte As Range, i&
    Dim rngAdr As Range, j&, arr1(1 To 6, 1 To 1), arr2(1 To 6, 1 To 1)
    If Not Intersect(Target, Range("rng_1")) Is Nothing Then
        Rows(2).Interior.Color = xlNone
        Columns(1).Interior.Color = xlNone
        Cells(2, Target.Column).Interior.Color = vbYellow
        Cells(Target.Row, 1).Interior.Color = vbYellow
    End If
    If Not Intersect(Target, Range("rng_2")) Is Nothing Then
        Rows(2).Interior.Color = xlNone
        Columns(1).Interior.Color = xlNone
        Cells(2, Target.Column - 1).Interior.Color = vbYellow
        Cells(Target.Row, 1).Interior.Color = vbYellow
    End If
    If Not Intersect(Target, Range("E23:E29")) Is Nothing Then
        i = InStr(1, Target.Cells.Value2(1, 1), "/")
        Set iZeile = Columns(1).Find(Mid(Target.Cells.Value2(1, 1), i + 1, 3), lookat:=xlWhole)
        If Target.Cells.Value2(1, 1) <> "" Then
            If Target.Cells.Value2(1, 1) <> "-" And Target.Cells.Value2(1, 1) <> "" Then
                Set iSpalte = Rows(2).Find(Left(Target.Cells.Value2(1, 1), i - 1), lookat:=xlWhole)
                Cells(iZeile.Row, iSpalte.Column).Select
            End If
        End If
    End If
    If Not Intersect(Target, Range("G23:G29")) Is Nothing Then
        i = InStr(1, Target.Cells.Value2(1, 1), "/")
        Set iZeile = Columns(1).Find(Mid(Target.Cells.Value2(1, 1), i + 1, 3), lookat:=xlWhole)
        If Target.Cells.Value2(1, 1) <> "-" And Target.Cells.Value2(1, 1) <> "" Then
            Set iSpalte = Rows(2).Find(Left(Target.Cells.Value2(1, 1), i - 1), lookat:=xlWhole)
            Cells(iZeile.Row, iSpalte.Column + 1).Select
        End If
    End If
   
'*****************************************************************************
   
    If Not Intersect(Target, Range("rng_3")) Is Nothing Then
        Dim k&
        Set rngAdr = Tabelle2.Columns(1).Find(Target.Cells.Address)
        If Not rngAdr Is Nothing Then
            With Tabelle2.ListObjects(1).DataBodyRange
                j = rngAdr.Row + 1 - .Row
                arr1(1, 1) = .Cells(j, 2)
                arr1(2, 1) = .Cells(j, 3)
                arr1(3, 1) = .Cells(j, 4)
                arr1(4, 1) = .Cells(j, 5)
                arr1(5, 1) = .Cells(j, 6)
                arr1(6, 1) = .Cells(j, 7)
                arr2(1, 1) = .Cells(j, 8)
                arr2(2, 1) = .Cells(j, 9)
                arr2(3, 1) = .Cells(j, 10)
                arr2(4, 1) = .Cells(j, 11)
                arr2(5, 1) = .Cells(j, 12)
                arr2(6, 1) = .Cells(j, 13)
                Application.EnableEvents = False
                For i = 1 To 6
                    Cells(22 + i, 12) = arr1(i, 1)
                    Cells(22 + i, 15) = arr2(i, 1)
                Next i
                Application.EnableEvents = True
            End With
        End If
    End If
   
'*****************************************************************************
End Sub