HERBERS Excel-Forum - das Archiv

Thema: Blatt anlegen - wenn Name doppelt dann Blattname_1

Blatt anlegen - wenn Name doppelt dann Blattname_1
markus

Hallo zusammen,
ich habe aus einem anderen Forum einen code der für mich ganz gut passt.
was ich gerne verändern würde ist, dass wenn der sheet name bereits vorhanden ist, der Zellwert um "_1" ..."_2" usw. für den Blattnamen hinzugefügt wird.
also anstatt dem Hinweis Blatt bereits vorhanden.
Kann mir da jemand helfen?
Danke

Option Explicit
Sub Bautagesberichte_anlegen()
Dim rngMuster As Range, calcOld As XlCalculation, zz As Long, ss As Long
Dim Calc As XlCalculation
Calc = Application.Calculation: Beschleuniger xlCalculationManual
Set rngMuster = Sheets("Kopierblatt").Columns("A:q")
With Sheets("Personalkalender")
For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
For ss = 1 To Sheets.Count
If Sheets(ss).Name = CStr(.Cells(zz, 1)) Then
MsgBox "Blatt '" & .Cells(zz, 1) & "' bereits vorhanden.", vbInformation
Exit For
End If
Next ss
If ss > Sheets.Count Then
Worksheets.Add after:=Sheets(Sheets.Count)
rngMuster.Copy Cells(1, 1)
Cells(2, 1) = .Cells(zz, 1)
ActiveSheet.Name = CStr(Cells(2, 1))
End If
Next zz
End With
Beschleuniger Calc
End Sub
'   Beschleuniger _______ Parameter: Calc-Status ______ gi/12.03.2006
'        Aufruf:
'           Dim Calc As XlCalculation
'           Calc = Application.Calculation: Beschleuniger xlCalculationManual
'           ....Code....
'           Beschleuniger Calc
Sub Beschleuniger(Optional StatCal As Long = xlCalculationAutomatic)
With Application
.Calculation = StatCal
.ScreenUpdating = (StatCal <> xlCalculationManual)
.EnableEvents = (StatCal <> xlCalculationManual)
End With
End Sub

AW: Blatt anlegen - wenn Name doppelt dann Blattname_1
Matthias

Hallo Markus,
bei dieser Lösung wird berücksichtigt, dass der Unterstrich mehrfach im Namen vorkommen kann und auch nicht zwingend ein Zähler nach dem Unterstrich stehen muss, Bsp.: "Max_Moritz_Mustermann". Der einfachere Weg wäre gewesen dir die Verwendung des Unterstriches außer für den Zähler zu verbieten, aber das wäre zu langweilig.
Sub Bautagesberichte_anlegen()
Dim rngMuster As Range, calcOld As XlCalculation, zz As Long, ss As Long
Dim Calc As XlCalculation
Dim sWksName As String, x As Long, fTmp
Calc = Application.Calculation: Beschleuniger xlCalculationManual
Set rngMuster = Sheets("Kopierblatt").Columns("A:q")
With Sheets("Personalkalender")
For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Namen erfassen
sWksName = CStr(.Cells(zz, 1))
Anfang:
For ss = 1 To Sheets.Count
'Name bereits vorhanden?
'Wenn ja neuen Zähler vergeben und Suche von vorn beginnen
If Sheets(ss).Name = sWksName Then
fTmp = Split(sWksName, "_") 'Namen zerlegen
If UBound(fTmp) = 0 Then 'kein Unterstrich vorhanden
sWksName = sWksName & "_1" 'Zähler anhängen
Else
If IsNumeric(fTmp(UBound(fTmp))) Then 'Zähler vorhanden
fTmp(UBound(fTmp)) = fTmp(UBound(fTmp)) + 1 'Zähler erhöhen
For x = 0 To UBound(fTmp) 'Namen wieder zusammenfügen
If x = 0 Then
sWksName = fTmp(0)
Else
sWksName = sWksName & "_" & fTmp(x)
End If
Next x
Else 'kein Zähler vorhanden
sWksName = sWksName & "_1" 'Zähler anhängen
End If
End If
GoTo Anfang 'Suche den neuen Namen
End If
Next ss
'Tabellenblatt erstellen
Worksheets.Add after:=Sheets(Sheets.Count)
rngMuster.Copy Cells(1, 1)
.Cells(zz, 1) = sWksName
Cells(2, 1) = .Cells(zz, 1)
ActiveSheet.Name = sWksName
Next zz
End With
Beschleuniger Calc
End Sub
lg Matthias

Blatt anlegen - wenn Name doppelt dann Blattname_1
markus

Hallo zusammen,
ich habe aus einem anderen Forum einen code der für mich ganz gut passt.
was ich gerne verändern würde ist, dass wenn der sheet name bereits vorhanden ist, der Zellwert um "_1" ..."_2" usw. für den Blattnamen hinzugefügt wird.
also anstatt dem Hinweis Blatt bereits vorhanden.
Kann mir da jemand helfen?
Danke

Option Explicit
Sub Bautagesberichte_anlegen()
Dim rngMuster As Range, calcOld As XlCalculation, zz As Long, ss As Long
Dim Calc As XlCalculation
Calc = Application.Calculation: Beschleuniger xlCalculationManual
Set rngMuster = Sheets("Kopierblatt").Columns("A:q")
With Sheets("Personalkalender")
For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
For ss = 1 To Sheets.Count
If Sheets(ss).Name = CStr(.Cells(zz, 1)) Then
MsgBox "Blatt '" & .Cells(zz, 1) & "' bereits vorhanden.", vbInformation
Exit For
End If
Next ss
If ss > Sheets.Count Then
Worksheets.Add after:=Sheets(Sheets.Count)
rngMuster.Copy Cells(1, 1)
Cells(2, 1) = .Cells(zz, 1)
ActiveSheet.Name = CStr(Cells(2, 1))
End If
Next zz
End With
Beschleuniger Calc
End Sub
'   Beschleuniger _______ Parameter: Calc-Status ______ gi/12.03.2006
'        Aufruf:
'           Dim Calc As XlCalculation
'           Calc = Application.Calculation: Beschleuniger xlCalculationManual
'           ....Code....
'           Beschleuniger Calc
Sub Beschleuniger(Optional StatCal As Long = xlCalculationAutomatic)
With Application
.Calculation = StatCal
.ScreenUpdating = (StatCal <> xlCalculationManual)
.EnableEvents = (StatCal <> xlCalculationManual)
End With
End Sub

AW: Blatt anlegen - wenn Name doppelt dann Blattname_1
Matthias

Hallo Markus,
bei dieser Lösung wird berücksichtigt, dass der Unterstrich mehrfach im Namen vorkommen kann und auch nicht zwingend ein Zähler nach dem Unterstrich stehen muss, Bsp.: "Max_Moritz_Mustermann". Der einfachere Weg wäre gewesen dir die Verwendung des Unterstriches außer für den Zähler zu verbieten, aber das wäre zu langweilig.
Sub Bautagesberichte_anlegen()
Dim rngMuster As Range, calcOld As XlCalculation, zz As Long, ss As Long
Dim Calc As XlCalculation
Dim sWksName As String, x As Long, fTmp
Calc = Application.Calculation: Beschleuniger xlCalculationManual
Set rngMuster = Sheets("Kopierblatt").Columns("A:q")
With Sheets("Personalkalender")
For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Namen erfassen
sWksName = CStr(.Cells(zz, 1))
Anfang:
For ss = 1 To Sheets.Count
'Name bereits vorhanden?
'Wenn ja neuen Zähler vergeben und Suche von vorn beginnen
If Sheets(ss).Name = sWksName Then
fTmp = Split(sWksName, "_") 'Namen zerlegen
If UBound(fTmp) = 0 Then 'kein Unterstrich vorhanden
sWksName = sWksName & "_1" 'Zähler anhängen
Else
If IsNumeric(fTmp(UBound(fTmp))) Then 'Zähler vorhanden
fTmp(UBound(fTmp)) = fTmp(UBound(fTmp)) + 1 'Zähler erhöhen
For x = 0 To UBound(fTmp) 'Namen wieder zusammenfügen
If x = 0 Then
sWksName = fTmp(0)
Else
sWksName = sWksName & "_" & fTmp(x)
End If
Next x
Else 'kein Zähler vorhanden
sWksName = sWksName & "_1" 'Zähler anhängen
End If
End If
GoTo Anfang 'Suche den neuen Namen
End If
Next ss
'Tabellenblatt erstellen
Worksheets.Add after:=Sheets(Sheets.Count)
rngMuster.Copy Cells(1, 1)
.Cells(zz, 1) = sWksName
Cells(2, 1) = .Cells(zz, 1)
ActiveSheet.Name = sWksName
Next zz
End With
Beschleuniger Calc
End Sub
lg Matthias

Bewerten Sie hier bitte das Excel-Portal