Blatt anlegen - wenn Name doppelt dann Blattname_1

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Blatt anlegen - wenn Name doppelt dann Blattname_1
von: markus
Geschrieben am: 12.11.2015 20:17:46

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

Bild

Betrifft: AW: Blatt anlegen - wenn Name doppelt dann Blattname_1
von: Matthias
Geschrieben am: 13.11.2015 02:44:50
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

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Blatt anlegen - wenn Name doppelt dann Blattname_1"