Option Explicit

Sub Макрос2()
     
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim arr As Variant
        If r.Cells.Count = 1 Then
            ReDim arr(1 To 1)
            arr(1) = r.Value
        Else
            arr = Intersect(Selection, ActiveSheet.UsedRange)
        End If
        Dim brr As Variant
        
        Dim v As Variant
        On Error Resume Next
        For Each v In arr
            Err.Clear
            With Sheets(v): End With
            If Err = 0 Then
                If IsEmpty(brr) Then
                    ReDim brr(0 To 0)
                Else
                    ReDim Preserve brr(0 To UBound(brr) + 1)
                End If
                brr(UBound(brr)) = v
            End If
        Next
        On Error GoTo 0
        Sheets(brr).Select
    End If
End Sub