Option Explicit

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

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ Code für MicrosoftExcelObjekt "DieseArbeitsmappe"
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Initialisierung der globalen Variablen
'+ beim Öffnen der Arbeitsmappe
'+
'+ Doppelklick verhindern
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Workbook_Open()
schutz_ist_ein = True
namecounter = 0
deaktiviere_Namen True
goto_next
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Überwachung aller Cursorbewegungen innerhalb der Arbeitsmappe
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Überwachung aller Cursorbewegungen ...
'+ bei Blattwechsel
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
   'nein,nein! so nicht!
   'so werden verbotenen Zellen nicht aktiviert!
   Dim aname As Name
   Dim r As Range
   If namecounter = 0 Then Exit Sub
   If InStr(1, Names(namecounter), Sh.Name) > 0 Then
      t_row = ActiveCell.Row
      t_col = ActiveCell.Column
      Else
      For Each aname In Names
         If InStr(1, aname.RefersTo, Sh.Name) > 0 Then
             GoTo erste_gefunden
             End If
         Next
Exit Sub
erste_gefunden:
      Application.EnableEvents = False
      aname.RefersToRange.Select
      Application.EnableEvents = True
      namecounter = aname.Index
      t_row = ActiveCell.Row
      t_col = ActiveCell.Column
      End If
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Überwachung aller Cursorbewegungen ...
'+ bei Doppelklick
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
Cancel = True
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Überwachung aller Cursorbewegungen ...
'+ bei Cursorbewegung
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim gotosheet As String
Dim gotoadresse As String
Dim is_sh As Long
Dim next_name As Integer
Dim a As Range
Dim b As Range
Dim r As Range

Dim aname As Name

Dim len_sheet As Integer
Dim anamerange As String
Dim sw As Boolean

On Error GoTo abbruch

If Not schutz_ist_ein Then Exit Sub
If namecounter < 0 Then Exit Sub
'If Target.Count > 1 Then Exit Sub 'oder besser?
If Target.Count > 1 Then Set Target = ActiveCell
   
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ Erweiterung: (WAHLFREIER ZUGRIFF AUF ERLAUBTE ZELLEN!)
'+ wenn Mausklick in irgendeinen erlaubten Zellbereich,
'+ dann wird der Cursor dorthingesetzt und die
'+ globale Variable namecounter erhält den aktuell
'+ gültigen Namensindex

Set b = Range(Target.AddressLocal)
On Error Resume Next
For Each aname In Names
len_sheet = InStr(1, aname.RefersTo, "!")
   If len_sheet > 0 Then
      If InStr(1, aname.RefersTo, ActiveSheet.Name) > 0 Then
         anamerange = Right$(aname.RefersTo, Len(aname.RefersTo) - len_sheet)
            Set a = Range(anamerange)
            Set r = Intersect(a, b)
            sw = False
            sw = (r.Count > 0)
            If sw Then
                namecounter = aname.Index
                t_row = aname.RefersToRange.Row
                t_col = aname.RefersToRange.Column
                Exit Sub
                End If
         End If
      End If
   Next
On Error GoTo abbruch
'+
'+ Ende der Erweiterung
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'vorwärts oder rückwärts durch die Namensliste?
If Target.Row <= t_row And Target.Column <= t_col Then
   next_name = -1
   Else
   next_name = 1
   End If
   
   namecounter = namecounter + next_name
   If namecounter > Application.Names.Count Then namecounter = 1
   If namecounter < 1 Then namecounter = Application.Names.Count
   
   Application.EnableEvents = False
   gotoadresse = Application.Names(namecounter)
   is_sh = InStr(1, gotoadresse, "!")
   If is_sh > 0 Then
      gotosheet = Mid(gotoadresse, 2, is_sh - 2)
      gotoadresse = Right(gotoadresse, Len(gotoadresse) - is_sh)
      Else
      gotosheet = ""
      End If
   Select Case gotosheet
      Case "": Range(gotoadresse).Select
      Case Else: Sheets(gotosheet).Activate
                 Range(gotoadresse).Select
      End Select
   Application.EnableEvents = True
   t_row = ActiveCell.Row
   t_col = ActiveCell.Column
   Exit Sub

abbruch:
   Application.EnableEvents = True
   MsgBox "Fehler"
   
   'Name löschen?
   'Application.Names(namecounter).Delete
   
   'oder Bezug ändern? (z.B. in aktive Zelle)
   Application.Names(namecounter).RefersTo = ActiveSheet.Name & "!" & ActiveCell.Address
   Application.Names(namecounter).RefersTo = WorksheetFunction.Substitute _
                    (Application.Names(namecounter).RefersTo, """", "")
   
   'und gehe zur nächsten benannten Zelle?
   namecounter = namecounter + next_name
   If namecounter > Application.Names.Count Then namecounter = 1
   If namecounter < 1 Then namecounter = Application.Names.Count
   goto_next
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ gehe zum nächsten benannten Bereich...
'+ starte SelectionChange mit Übergabeparametern im VBA Code
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Public Sub goto_next()
Workbook_SheetSelectionChange ActiveSheet, ActiveCell
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ setzt den Menupunkt Namen zurück auf Enabled=True
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
deaktiviere_Namen False
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Option Explicit

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

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ Code für Module (z.B.) "Modul1"
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ globale Variablen
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public namecounter As Long
Public schutz_ist_ein As Boolean
Public t_row As Long
Public t_col As Long
'Namenbutton im Menu deaktivieren
Public cbc_c As CommandBarControl


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ stelle definierten Anfangszustand her (=Reset auf Anfangszustand)
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub reset_namecounter()
namecounter = 0
t_row = 0
t_col = 0
schutz_ist_ein = True
deaktiviere_Namen True
ThisWorkbook.goto_next
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ temporär den Zellschutz ein- und ausschalten
'+ evtl kann man diese Prozedur auch entfernen oder PRIVATE setzen!
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub zellschutz()
schutz_ist_ein = Not schutz_ist_ein
If schutz_ist_ein Then
   MsgBox "Zellschutz über Namensliste" & vbNewLine & "ist jetzt eingeschaltet!"
   deaktiviere_Namen True
   Else
   MsgBox "Zellschutz ist temporär" & vbNewLine & "  ABGESCHALTET !  "
   deaktiviere_Namen False
   End If
End Sub


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ während der Laufzeit wird der Menupunkt Name DEAKTIVIERT
'+ damit können im geschützten Zustand keine neuen Namen
'+ über diesen Button angelegt werden
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub deaktiviere_Namen(namedisable As Boolean)
On Error GoTo err_hdl
   Dim am As CommandBar
   Dim cbc As CommandBarControl
   Set am = CommandBars.ActiveMenuBar
   For Each cbc In am.Controls
      If cbc.Caption = "&Einfügen" Then GoTo weiter
      Next cbc
weiter:
   For Each cbc_c In cbc.Controls
      If cbc_c.Caption = "&Namen" Then GoTo weiter2
      Next cbc_c
weiter2:
   cbc_c.Enabled = Not namedisable
   Exit Sub
err_hdl:
   MsgBox "Fehler beim Versuch den [Namen]Button zu deaktivieren"
 End Sub