'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr
'

Option Explicit
Public SprungAdressenBlattName As String
Public springe_ist_ein As Boolean
    

Public Sub setze_SprAdr(sh_name As String)
    SprungAdressenBlattName = sh_name
End Sub

Public Sub setze_SprAdrAS()
    SprungAdressenBlattName = ActiveSheet.Name
End Sub

'folgende Sub muß jeder selbst anpassen ODER
'das gewünschte Blatt zu Beginn 1x selektieren und
'setze_SprAS aufrufen, damit wird definiert,
'welches Arbeitsblatt die Adressen enthält.
Private Sub Workbook_Open()
    reset_springen
End Sub

'in der Tabelle (worksheet) mit Namen "sprungadr" wird das Sprungziel
'als String eingetragen. Immer wenn ein Wert in einer Zelle geändert
'wurde wird dann geprüft, in welche Zelle der Cursor danach springen soll.
'Format der Sprungadresse ist <arbeitsblattname>!<absolute Zelladresse>
'd.h. steht in sprungadr!A1 der String Tabelle1!$E$7, dann springt nach
'Eingabe/Änderung in JEDER Zelle A1 der Cursor immer in die Zelle E7 und zwar
'im Arbeitsblatt "Tabelle1"

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim the_range As String, isrange As String
Dim issheet As Variant
Dim test As String, komma As String
Dim r_offs As Long, c_offs As Long

On Error GoTo unkorrekt
If springe_ist_ein Then
    the_range = ""
    If Target.Count = 1 Then
        the_range = Sheets(SprungAdressenBlattName).Range(Target.Address)
        Else
        the_range = Sheets(SprungAdressenBlattName).Range(LinkeZelle(Target))
        End If
    If Left(the_range, 1) = "s" Then Exit Sub
    If Target.Count = 1 Then
        the_range = is_goto(Target.Value, the_range)
        Else
        the_range = is_goto(LinkerWert(Target), the_range)
        End If
    issheet = is_sheetname(the_range)
    isrange = is_range(the_range)
    If Not IsEmpty(issheet) And Not IsEmpty(isrange) Then
        Sheets(issheet).Select
        If Left(isrange, 1) <> "%" Then
            Range(isrange).Select
            Else 'relative Adresse
            test = Right(isrange, Len(isrange) - 1)
            komma = InStr(1, test, ",")
            r_offs = Left(test, komma - 1)
            c_offs = Right(test, Len(test) - komma)
            If Target.Count = 1 Then
                Range(Target.Address).Cells.Offset(r_offs, c_offs).Select
                Else
                Range(LinkeZelle(Target)).Cells.Offset(r_offs, c_offs).Select
                End If
            End If
            Exit Sub
        End If
    If Not IsEmpty(isrange) Then
        If Left(isrange, 1) <> "%" Then
            Range(isrange).Select
            Else 'relative Adresse
            test = Right(isrange, Len(isrange) - 1)
            komma = InStr(1, test, ",")
            r_offs = Left(test, komma - 1)
            c_offs = Right(test, Len(test) - komma)
            If Target.Count = 1 Then
                Range(Target.Address).Cells.Offset(r_offs, c_offs).Select
                Else
                Range(LinkeZelle(Target)).Cells.Offset(r_offs, c_offs).Select
                End If
            End If
        End If
        Exit Sub
    End If
unkorrekt:
'hier eigene Verhaltensweisen des Change-Events einbauen!
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim the_range As String, isrange As String
Dim issheet As Variant
Dim test As String, komma As String
Dim r_offs As Long, c_offs As Long

On Error GoTo unkorrekt
If springe_ist_ein Then
    the_range = ""
    If Target.Count = 1 Then
        the_range = Sheets(SprungAdressenBlattName).Range(Target.Address)
        Else
        the_range = Sheets(SprungAdressenBlattName).Range(LinkeZelle(Target))
        End If
    If Left(the_range, 1) = "s" Then
        If Target.Count = 1 Then
            the_range = is_goto(Target.Value, Right(the_range, Len(the_range) - 1))
            Else
            the_range = is_goto(LinkerWert(Target), Right(the_range, Len(the_range) - 1))
            End If
        issheet = is_sheetname(the_range)
        isrange = is_range(the_range)
        If Not IsEmpty(issheet) And Not IsEmpty(isrange) Then
            Sheets(issheet).Select
            If Left(isrange, 1) <> "%" Then
                Range(isrange).Select
                Else 'relative Adresse
                test = Right(isrange, Len(isrange) - 1)
                komma = InStr(1, test, ",")
                r_offs = Left(test, komma - 1)
                c_offs = Right(test, Len(test) - komma)
                If Target.Count = 1 Then
                    Range(Target.Address).Cells.Offset(r_offs, c_offs).Select
                    Else
                    Range(LinkeZelle(Target)).Cells.Offset(r_offs, c_offs).Select
                    End If
                End If
            Exit Sub
            End If
        If Not IsEmpty(isrange) Then
            If Left(isrange, 1) <> "%" Then
                Range(isrange).Select
                Else 'relative Adresse
                test = Right(isrange, Len(isrange) - 1)
                komma = InStr(1, test, ",")
                r_offs = Left(test, komma - 1)
                c_offs = Right(test, Len(test) - komma)
                If Target.Count = 1 Then
                    Range(Target.Address).Cells.Offset(r_offs, c_offs).Select
                    Else
                    Range(LinkeZelle(Target)).Cells.Offset(r_offs, c_offs).Select
                    End If
                End If
            End If
            Exit Sub
        End If
    End If
unkorrekt:
'hier eigene Verhaltensweisen des SelectionChange-Events einbauen!
End Sub


Private Function is_sheetname(ByVal s As String) As Variant
Dim test As String
Dim offs As Long
  is_sheetname = Empty
  test = InStr(1, s, "!")
  If test > 0 Then
     is_sheetname = Left(s, test - 1)
  End If
  
  test = is_sheetname
  
  ' man kann auch ohne den Tabellennamen RELATIV zum
  ' aktiven Tabellenindex springen
  ' Tabelle als relatives Sprungziel!
  ' [2] springe zu 2. Tabelle
  ' [+1] springe 1 Tabelle weiter nach hinten
  ' [-3] springe 3 Tabellen weiter nach vorn
  ' wenn NICHT möglich wird Sprung nicht ausgeführt
  ' z.Bsp: [+3]!$A$1 springt von der jetzigen Tabelle
  ' um 3 Blätter weiter nach hinten in Zelle A1
  
  If Left(test, 1) = "[" Then
     test = Mid(test, 2, Len(test) - 2)
     Select Case Left(test, 1)
       Case "+":
          offs = CInt(Right(test, Len(test) - 1))
       Case "-":
          offs = -1 * CInt(Right(test, Len(test) - 1))
       Case Else:
          offs = CLng(test) - ActiveSheet.Index
     End Select
     is_sheetname = ActiveSheet.Index + offs
  End If
End Function

Private Function is_range(ByVal s As String) As String
Dim test As String
  is_range = s
  test = InStr(1, s, "!")
  If test > 0 Then
     is_range = Right(s, Len(s) - test)
  End If
  
  test = is_range
  
  ' man kann auch ohne die absolute Adresse RELATIV zur
  ' aktiven Zelle springen
  ' Zelle als relatives Sprungziel!
  ' [2,3] springe mit Zelloffset (+2,+3) weiter
  ' [+1,-4] springe von z.B. E1 nach A2
  ' wenn NICHT möglich wird Sprung nicht ausgeführt
  
  If Left(test, 1) = "[" Then
     test = Mid(test, 2, Len(test) - 2)
     'die nächsten 4 Zeilen können durch eine Zeile ersetzt werden
     'komma = InStr(1, test, ",")
     'r_offs = Left(test, komma - 1)
     'c_offs = Right(test, Len(test) - komma)
     'is_range = "%" & r_offs & "," & c_offs
     'das aufsplitten ist an dieser Stelle sinnlos, wäre nur
     'vertretbar, wenn gleichzeitig eine Plausibilitätsprüfung
     'der Eingabewerte durchgeführt würde ... folgendes reicht völlig
     is_range = "%" & test
  End If

End Function

Private Function is_goto(ByVal tvar As Variant, ByVal s As String) As String
Dim test As String
Dim isfirst As Boolean
is_goto = s
If Left(s, 1) = "|" Then
    s = Right(s, Len(s) - 1)
    test = Left(s, InStr(1, s, "|") - 1)
    s = Right(s, Len(s) - InStr(1, s, "|"))
    
    Select Case Left(test, 1)
        Case "=": isfirst = vergleich_tvar_test(tvar, test, "=")
        Case "<": Select Case Mid(test, 2, 1)
                      Case "=": isfirst = vergleich_tvar_test(tvar, test, "<=")
                      Case ">": isfirst = vergleich_tvar_test(tvar, test, "<>")
                      Case Else: isfirst = vergleich_tvar_test(tvar, test, "<")
                      End Select
        Case ">": Select Case Mid(test, 2, 1)
                      Case "=": isfirst = vergleich_tvar_test(tvar, test, ">=")
                      Case Else: isfirst = vergleich_tvar_test(tvar, test, ">")
                      End Select
        End Select
    If isfirst Then
        is_goto = Left(s, InStr(1, s, "|") - 1)
        Else
        is_goto = Right(s, Len(s) - InStr(1, s, "|"))
        End If
    End If
End Function

Private Function vergleich_tvar_test(ByVal tvar As Variant, test As String, operator As String) As Boolean
    vergleich_tvar_test = False
    test = Right(test, Len(test) - Len(operator))
    Select Case Left(test, 1)
        Case """":
            Select Case operator
                Case "=":
                    If CStr(tvar) = Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
                Case "<":
                    If CStr(tvar) < Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
                Case ">":
                    If CStr(tvar) > Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
                Case "<=":
                     If CStr(tvar) <= Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
               Case ">=":
                     If CStr(tvar) >= Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
               Case "<>":
                    If CStr(tvar) <> Mid(test, 2, Len(test) - 2) Then vergleich_tvar_test = True
                End Select
        Case Else:
            Select Case operator
                Case "=":
                    If tvar = Val(test) Then vergleich_tvar_test = True
                Case "<":
                    If tvar < Val(test) Then vergleich_tvar_test = True
                Case ">":
                     If tvar > Val(test) Then vergleich_tvar_test = True
                Case "<=":
                     If tvar <= Val(test) Then vergleich_tvar_test = True
                Case ">=":
                    If tvar >= Val(test) Then vergleich_tvar_test = True
                Case "<>":
                    If tvar <> Val(test) Then vergleich_tvar_test = True
                End Select
            
        End Select
        
End Function

Public Sub springen_EinAus()
Dim mtext As String
springe_ist_ein = Not springe_ist_ein
mtext = "AUS"
If springe_ist_ein Then mtext = "EIN"
MsgBox "Das Springen ist jetzt" & Chr(10) _
       & "  " & mtext & "geschaltet!"
End Sub

Public Sub reset_springen()
    'definiere zu Beginn letztes Blatt als Sprungadressblatt
    setze_SprAdr (Sheets(Worksheets.Count).Name)
    springe_ist_ein = True
End Sub

'die nächsten beiden Funktionen dienen nur dazu die TargetAdresse VERBUNDENER ZELLEN
'aufzulösen und die Zelle LINKS OBEN als Referenz an das Sprungzielblatt zu
'übergeben. Das Sprungzielblatt sollte KEINE VERBUNDENEN ZELLEN enthalten, da sonst
'u.U. Target.Value nicht definiert ist und manche Sprünge dann nicht ausgeführt werden!

Private Function LinkeZelle(r As Excel.Range) As String
Dim position As Integer
LinkeZelle = ""
position = InStr(1, r.Address, ":")
If position < 1 Then
    LinkeZelle = r.Address
    Else
    LinkeZelle = Left(r.Address, position - 1)
    End If
End Function

Private Function LinkerWert(r As Excel.Range) As Variant
LinkerWert = Range(LinkeZelle(r)).Value
End Function