Zelleninhalte>Anlegen gleichlautender Tab.blätter
11.07.2011 20:14:04
fcs
JAT,
hier ein Makro zum Anlegen der Blätter. Die Namen im Zellbereich werden werden auch geprüft, ob sie alls Blattnamen zulässig sind.
Gruß
Franz
Sub aaTabellen_anlegen()
Dim oRange As Range, Zelle As Range, wksNeu As Worksheet, oWB As Workbook, vType
Dim icount As Integer, sName As String
On Error GoTo Fehler
Set oWB = ActiveWorkbook
Set oRange = Selection
vType = xlWorksheet 'Standardworksheet anfügen
'vType = "C:\Users\MyName\Vorlagen\MusterVorlage.xlst" 'Vordefinierte Vorlage einfügen
Application.ScreenUpdating = False
For Each Zelle In oRange
icount = icount + 1
If Zelle "" Then
sName = Zelle.Text
sName = CheckSheet(sName)
If sName "" Then
Application.StatusBar = "Blatt " & Zelle.Text & " (" & icount & " von " _
& oRange.Cells.Count & ") wird angelegt"
Set wksNeu = oWB.Worksheets.Add(After:=oWB.Sheets(oWB.Sheets.Count), Type:=vType)
wksNeu.Name = sName
Zelle.Parent.Hyperlinks.Add Anchor:=Zelle, Address:="", SubAddress:="'" & sName & "'!A1", _
_
ScreenTip:="Tabellenblatt: " & wksNeu.Name
End If
Resume01:
End If
Next Zelle
oRange.Parent.Activate
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 1004
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
Resume Resume01
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.StatusBar = False
End Sub
Private Function CheckSheet(ByVal sBlattName As String, Optional oWB As Workbook) As String
Dim arrZeichen, oSheet As Object, arrUnzul, iJ As Integer
'Prüfen, ob Blatt schon vorhanden
If oWB Is Nothing Then Set oWB = ActiveWorkbook
CheckName:
For Each oSheet In oWB.Sheets
If UCase(oSheet.Name) = UCase(sBlattName) Then
MsgBox "Ein Blatt mit dem Namen """ & sBlattName & """ existiert bereits. Name wird ü _
bersprungen"
CheckSheet = ""
GoTo Beenden:
End If
Next
'Prüfen auf ungültige Zeichen ? [ ] / \ * :
arrUnzul = Array("?", "[", "]", "/", "\", "*", ":")
For iJ = LBound(arrUnzul) To UBound(arrUnzul)
If InStr(1, sBlattName, arrUnzul(iJ)) > 0 Then
sBlattName = InputBox(Prompt:="Der Blattname """ & sBlattName _
& """ enthält eines der unzulässigen Zeichen ? [ ] / \ * :" _
& vbLf & "Bitte Name anpassen", Title:="Prüfung Blattname - " & sBlattName, _
Default:=sBlattName)
If sBlattName = "" Then
CheckSheet = ""
GoTo Beenden
Else
GoTo CheckName
End If
End If
Next
'Prüfen maximale Länge 31 Zeichen
If Len(sBlattName) > 31 Then
sBlattName = InputBox(Prompt:="Der Blattname """ & sBlattName & """ hat mehr als 31 _
Zeichen" _
& vbLf & "Bitte Name anpassen", Title:="Prüfung Blattname - " & sBlattName, _
Default:=Left(sBlattName, 31))
If sBlattName = "" Then
CheckSheet = ""
GoTo Beenden
Else
GoTo CheckName
End If
End If
CheckSheet = sBlattName
Beenden:
Set oSheet = Nothing
End Function