Sub MarkenNamenBlaetterErzeugen()
->Quellblatt
Const c_BltMarken = Marken
Const c_SPMarke = 1->entspricht Spalte A
Const c_ZersteWerteZeile = 70
Const c_ZletzteWerteZeile = 120
->zu kopierendes Blatt
Const c_BltTemplate = Anforderungen
->Zielblatt
Const c_NamenAuf31ZeichenKuerzen As Boolean = False
Const c_NamenUngueltigeZeichenErsetzen As Boolean = False
Const c_Erstazzeichen As String = _
Dim wb As Workbook
Dim wsq As Worksheet, wst As Worksheet, wsz As Worksheet
Dim s_Blatt As String, l_qZeileMax As Long, x As Long
Set wb = ActiveWorkbook
On Error GoTo ErrorhandlerBlatt:
s_Blatt = c_BltMarken
Set wsq = Worksheets(s_Blatt)
s_Blatt = c_BltTemplate
Set wst = Worksheets(s_Blatt)
On Error GoTo 0
->auskommentiert da feste letzte Zeile c_ZletzteWerteZeile
->für variable Anzahl von Marken kann in der folgenden
-> For-Anweisung c_ZletzteWerteZeile durch l_qZeileMax ersetzt werden
-> wenn in der Spalte Marken keine weiteren Information nach den
->Marken stehen
->l_qZeileMax = wsq.Cells(wsq.Rows.Count, c_SPMarke).End(xlUp).Row
->Über alle Marken
For x = c_ZersteWerteZeile To c_ZletzteWerteZeile
->nächster Markenname
s_Blatt = Trim(wsq.Cells(x, c_SPMarke).Value)
->Blattnamen prüfen
->ggf Ersatzzeichen _ und auf 31 Zeichen kürzen
If BlattnamePruefen(s_Blatt, _
c_NamenUngueltigeZeichenErsetzen, _
c_Erstazzeichen, _
c_NamenAuf31ZeichenKuerzen) Then
->Blattname bereits vorhanden pruefen
If BlattnameExistiertNichtPruefen(wb, s_Blatt) Then
->TemplateBlatt ans Ende kopieren
wst.Activate
wst.Copy After:=wb.Worksheets(wb.Worksheets.Count)
Set wsz = ActiveSheet
->neues Blatt mit Markennamen versehen
wsz.Name = s_Blatt
Else
MsgBox (Blatt & s_Blatt & existiert bereits !)
End If
End If
Next
Aufraeumen:
Set wb = Nothing: Set wsq = Nothing: Set wsz = Nothing: Set wst = Nothing
Exit Sub
ErrorhandlerBlatt:
Err.Clear
MsgBox (Blatt & s_Blatt & konnte nicht angesprochen werden.)
GoTo Aufraeumen
End Sub
'****************************************************************
Private Function BlattnameExistiertNichtPruefen(wb As Workbook, s_Blatt As String) As Boolean
On Error Resume Next
wb.Worksheets(s_Blatt).Activate
If Err.Number = 0 Then
BlattnameExistiertNichtPruefen = False
Else
Err.Clear
BlattnameExistiertNichtPruefen = True
End If
On Error GoTo 0
End Function
'****************************************************************
Private Function BlattnamePruefen(s_BlattName As String, _
b_Ersatz As Boolean, _
s_Ersatzzeichen As String, _
b_Kuerzen As Boolean) As Boolean
'****************************************************************
'b_Ersatz:
' True - bei unzulässige Zeichen werden durch Erstazzeichen ersetzt
'b_Kuerzen:
' True - wenn der Blattname mehr als 31 Zeichen hat, wird er auf 31 gekürzt
Dim x As Long, s As String, s_OutPut As String
BlattnamePruefen = False
->prüfen: Blattname leer
If s_BlattName = Then Exit Function
->Zeichen auf zulässigkeit prüfen
For x = 1 To Len(s_BlattName)
s = Mid(s_BlattName, x, 1)
Select Case s
Case 0 To 9, a To z, A To Z, Ä, ä, Ö, ö, Ü, ü, ß
Case ,, ., _, -, #,->, +, =, ), (, ], [, }, {
Case ;, &, %, $, §, !, @, <, >
Case Else
If b_Ersatz Then
s = s_Ersatzzeichen
Else
MsgBox (Zeichen & x & des Blattnamens-> & s_BlattName &-> unzulässig!)
Exit Function
End If
End Select
s_OutPut = s_OutPut & s
Next
->Ersetzenmodus: korrigierten Blattnamen setzen
If b_Ersatz Then s_BlattName = s_OutPut
->prüfen: max. Länge überschritten
If Len(s_BlattName) > 31 Then
If b_Kuerzen Then
s_BlattName = Left(s_BlattName, 31)
Else
MsgBox ( _
Blattname-> & s_BlattName &-> hat mehr als 31 Zeichen -> unzulässig !)
Exit Function
End If
End If
BlattnamePruefen = True
End Function
