AW: Ergänzung: Registerlasche
10.01.2004 14:03:57
andre
hallo ernst,
du machst ja arbeit ...
'************************************************************
'in diesearbeitsmappe:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
NameBeimSchliessen
End Sub
Private Sub Workbook_Open()
NameBeimOeffnen
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
NameBeimWechseln
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
NameBeimWechseln
End Sub
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
NameBeimWechseln
End Sub
'************************************************************
'in ein modul:
Option Explicit
Public a(), i%, wieviele%, noch%
Sub NameBeimOeffnen()
'
'programmiert von andre schau am 11.01.04
'einschränkung: von den ersten 4 blättern darf keines gelöscht werden
'die blatteihenfolge ergibt ansonsten sich aus der reihenfolge beim öffnen
'
Dim j%, namen
wieviele = Sheets.Count
'die nächste bedingung kommt wegen der gewünschten begrenzung auf die
'erste 4 blätter und findet sich noch öfter im code
If wieviele > 4 Then wieviele = 4
ReDim a(1 To wieviele, 1 To 3)
i = 0
For Each namen In Sheets()
i = i + 1
If i > 4 Then Exit Sub 'wieder die 4
a(i, 1) = namen.Name
a(i, 2) = namen.Index
'item feststellen - wird benötigt, da sheets(1) sich auf die blattliste der
'ansicht bezieht und nicht auf die reihenfolge im vbproject
For j = 1 To ThisWorkbook.VBProject.VBComponents.Count
If ThisWorkbook.VBProject.VBComponents.Item(j).Type = 100 And _
Left(ThisWorkbook.VBProject.VBComponents.Item(j).Name, 3) = "Tab" Then
If Sheets(i).Name = ThisWorkbook.VBProject.VBComponents.Item(j).Properties.Item("Name") Then
a(i, 3) = ThisWorkbook.VBProject.VBComponents.Item(j).Name
End If
End If
Next
Next
End Sub
Sub NameBeimSchliessen()
Dim namen
i = 1
If Sheets(1).Name <> a(1, 1) Then
Sheets(a(1, 1)).Move before:=Sheets(1)
End If
If UBound(a()) > 1 Then
For i = 2 To UBound(a())
Sheets(a(i, 1)).Move after:=Sheets(i - 1)
Next
End If
ActiveWorkbook.Save
End Sub
Sub NameBeimWechseln()
Dim k%, j%
'dieses if verhindert die ausführung dieses sub beim anlegen
'oder löschen neuer blätter
If Sheets.Count <> wieviele Then
noch = noch + 1
If noch = 1 Then
noch = 0
wieviele = Sheets.Count
End If
Exit Sub
End If
'hier wird beim aktivieren oder deaktivieren des blattes oder
'dem deaktivieren der mappe der alte blattname gesetzt
For j = 1 To ThisWorkbook.VBProject.VBComponents.Count
If ThisWorkbook.VBProject.VBComponents.Item(j).Type = 100 And _
Left(ThisWorkbook.VBProject.VBComponents.Item(j).Name, 3) = "Tab" Then
For k = 1 To UBound(a())
If a(k, 3) = ThisWorkbook.VBProject.VBComponents.Item(j).Name Then
ThisWorkbook.VBProject.VBComponents.Item(j).Properties.Item("Name") = a(k, 1)
End If
Next
End If
Next
End Sub
'************************************************************
Beispielmappe:
https://www.herber.de/bbs/user/2864.xls
gruss andre