AW: tabellenblatt automatisch erstellen
06.05.2013 08:37:14
Klaus
Hallo Lippmann,
rechtsclick auf den Reiter deiner Tabelle "Aufgaben" und dann auf "Code anzeigen". In das große weiße Fenster kopierst du unten stehenden Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo hell
Dim iCol As Integer
Dim lRow As Long
Dim wksOld As Worksheet
Dim sZiel As String
'Vorgänge IN Spalte 1 (=A), und AB Zeile 2
iCol = 1
lRow = 2
'Hyperlinkziel in neuen Tabellen: A1
sZiel = "A1"
Set wksOld = ActiveSheet 'aktives Blatt merken
'Abbruch bei Mehrfachauswahl
If Target.Rows.Count > 1 Then GoTo heaven
If Target.Columns.Count > 1 Then GoTo heaven
If Target.Column = iCol And Target.Row >= lRow And Not Target.Value = "" Then
If WksSheetExists(Target.Value) Then
If MsgBox("Ein Blatt Namens " & Target.Value & " gibt es schon!" & Chr(10) & "neue _
Aktivität löschen?", vbYesNo) = 6 Then
Target.ClearContents
End If
Else
Sheets.Add After:=Worksheets(Worksheets.Count) 'neues Sheet
ActiveSheet.Name = Target.Value 'sheet umbenennen
'bei ungültigem Namen greift "onError"
End If
End If
GoTo heaven:
hell: 'unnötiges Blatt (falscher Name) löschen und Fehlermeldung ausgeben
If Not wksOld.Name = ActiveSheet.Name Then
'IF-Block nicht notwendig, aber Sicherheit geht vor!
If MsgBox("Fehler - warscheinlich ein ungültiger Name!" & Chr(10) & "unnötiges Sheet lö _
schen?", vbYesNo) = 6 Then
Application.DisplayAlerts = False
ActiveSheet.Delete
End If
End If
heaven:
Application.DisplayAlerts = True
wksOld.Activate
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Statt Hyperlinks: Sheetwechsel per VBA
'Abbruch bei Mehrfachauswahl
If Target.Rows.Count > 1 Then GoTo heaven
If Target.Columns.Count > 1 Then GoTo heaven
'Sheet wechseln, falls möglich
If WksSheetExists(Target.Value) Then Sheets(Target.Value).Activate
heaven:
End Sub
Function WksSheetExists(sSheet As String) As Boolean
'Function prüft, ob ein Sheet bereits vorhanden ist
Dim wks As Object
On Error Resume Next
Set wks = Sheets(sSheet)
If Not wks Is Nothing Then
WksSheetExists = True
End If
On Error GoTo 0
End Function
Statt Hyperlinks habe ich den Blattwechsel per VBA gelöst. Kannst die Spalte ja blau+unterstrichen formatieren, dann sehen die Vorgangsnamen auch aus wie Hyperlinks.
Grüße,
Klaus M.vdT.