Blatt mehrfach kopieren und fortlaufend

[Volkii]

Hallo Zusammen,

ich habe eine Excel Datei (M365) mit mehreren Arbeitsblättern. Ein Blatt heißt "TEMPLATE". Dieses Blatt möchte ich jetzt per MARKO x mal kopieren und zeitgleich
fortlaufend umbenennen in "001", "002", "003" und so weiter. Ich habe auch schon einige Makros gefunden die zumindest den ersten Teil (mehrfach kopieren) durchführen.

Vielleicht kann mir hier ein Excel Profi helfen. Bei der Erläuterung bitte daran denken, dass ich mit Makros und VBA noch nicht gearbeitet habe.

Vielen lieben Dank
Volker

[DIZA]

Hallo Volker,

Code:

Option Explicit
Sub Blcopies()
Dim Menge As Long, C As Long, nn As String

Menge = InputBox("Wieviele Blattkopien sollen erstellt werden ?")
For C = 1 To Menge
   nn = Format(C, "000")
      Sheets("TEMPLATE").Copy After:=Sheets(Sheets.Count)
      ActiveSheet.Name = nn
Next C
End Sub

wäre eine Möglichkeit.

[Peter]

Hallo,

vorweg: ich habe von VBA keine große Ahnung. Der nachfolgende Code wurde zu 100% von ChatGPT erstellt und ist mit entsprechender Vorsicht zu genießen (Hinweis von ChatGPT: "Stellen Sie sicher, dass Sie eine Sicherungskopie Ihrer Excel-Datei haben, bevor Sie das Makro ausführen.")

Ich habe den Code getestet, er tut was er soll - ich kann allerdings mangels meiner sehr geringen VBA-Kenntnisse nicht sagen ob der Code noch optimiert werden könnte und wie die "Qualität" des Codes ist. Ich habe das Ganze eher als "Spielerei" und Testen von ChatGPT angesehen, wollte das Ergebnis aber auch nicht hinter dem Berg halten.

Code:

Sub CopyAndRename()
Dim i As Integer    ' Deklariert eine Integer-Variable "i" für die Schleife
Dim ws As Worksheet    ' Deklariert eine Variable "ws" vom Typ Worksheet
Dim newWs As Worksheet    ' Deklariert eine Variable "newWs" vom Typ Worksheet
Dim numSheets As Integer    ' Deklariert eine Variable "numSheets" für die Anzahl der gewünschten Tabellenblätter
Dim sheetName As String    ' Deklariert eine Variable "sheetName" für den Namen des neuen Blatts

On Error Resume Next    ' Aktiviert die Fehlerbehandlung

numSheets = InputBox("Bitte geben Sie die Anzahl der gewünschten Tabellenblätter ein.")    ' Zeigt eine Eingabeaufforderung an, um die Anzahl der gewünschten Tabellenblätter abzurufen

Set ws = Sheets("TEMPLATE")    ' Weist die Variable "ws" dem Blatt "TEMPLATE" zu

For i = 1 To numSheets    ' Startet eine Schleife von 1 bis zur Anzahl der gewünschten Tabellenblätter
    sheetName = Format(i, "000")    ' Definiert den Namen des neuen Blatts in fortlaufender Nummerierung, beginnend bei "001"
    
    ' Überprüft, ob ein Blatt mit dem gleichen Namen bereits vorhanden ist
    If SheetExists(sheetName) Then
        MsgBox "Ein Blatt mit dem Namen " & sheetName & " ist bereits vorhanden. Der Vorgang wird abgebrochen.", vbExclamation    ' Zeigt eine Hinweismeldung an
        Exit Sub    ' Beendet den VBA-Code
    Else
        ws.Copy After:=Sheets(Sheets.Count)    ' Kopiert das Blatt "TEMPLATE" und fügt es nach dem letzten Blatt ein
        Set newWs = ActiveSheet    ' Weist die Variable "newWs" dem neu erstellten Blatt zu
        newWs.Name = sheetName    ' Benennt das neue Blatt in fortlaufender Nummerierung um, beginnend bei "001"
    End If
Next i    ' Beendet die Schleife

End Sub

Function SheetExists(sheetName As String) As Boolean
    ' Prüft, ob ein Blatt mit dem angegebenen Namen bereits vorhanden ist
    Dim ws As Worksheet
    SheetExists = False    ' Initialisiert die Rückgabevariable als "False"
    For Each ws In ThisWorkbook.Worksheets    ' Durchsucht alle Blätter in der Arbeitsmappe
        If ws.Name = sheetName Then
            SheetExists = True    ' Wenn ein Blatt mit dem gleichen Namen gefunden wird, setzt die Rückgabevariable auf "True"
            Exit Function    ' Beendet die Funktion frühzeitig
        End If
    Next ws
End Function

Der Code gehört in ein allgemeines Modul. Schau dir dazu, falls notwendig z.B. diese Seite an: http://www.j-hennekes.de/1033846.htm oder auch https://www.online-excel.de/excel/singsel_vba.php?f=44

Ich habe dann neugierigerweise in einem zweiten Schritt im aktuellen Edge das "neue Bing" getestet und folgende Code erhalten der auch erfolgreich durchgelaufen ist.

Code:

Sub KopierenUndUmbenennen()
    Dim i As Integer 'Variable für die Schleife
    Dim ws As Worksheet 'Variable für das Blatt "TEMPLATE"
    Dim Anzahl As Integer 'Variable für die Anzahl der gewünschten Blätter
    
    Set ws = Sheets("TEMPLATE") 'Setzen Sie die Variable "ws" auf das Blatt "TEMPLATE"
    
    Anzahl = InputBox("Geben Sie die Anzahl der gewünschten Tabellenblätter ein:") 'Fordern Sie den Benutzer auf, die Anzahl der gewünschten Blätter einzugeben
    
    For i = 1 To Anzahl 'Schleife durchlaufen
        On Error Resume Next 'Fehler ignorieren
        ws.Copy After:=Sheets(Sheets.Count) 'Kopieren Sie das Blatt "TEMPLATE" und fügen Sie es nach dem letzten Blatt ein
        ActiveSheet.Name = Format(i, "000") 'Benennen Sie das neue Blatt in "001", "002", "003" usw. um
        If Err.Number <> 0 Then 'Wenn ein Fehler auftritt
            MsgBox "Das Blatt " & Format(i, "000") & " existiert bereits." 'Zeigen Sie eine Fehlermeldung an
            Err.Clear 'Löschen Sie den Fehler
            Exit Sub 'Beenden Sie das Makro
        End If
    Next i 'Nächste Schleife durchlaufen
End Sub

Dort wurde mir unaufgefordert auch der folgende Hinweis für die Verwendung von Makros mitgegeben:

Um das Makro zu verwenden, öffnen Sie Ihre Excel-Datei und drücken Sie ALT + F11, um den Visual Basic Editor zu öffnen. Klicken Sie auf “Einfügen” und wählen Sie “Modul”. Fügen Sie den obigen Code in das Modul ein und speichern Sie es. Schließen Sie den Visual Basic Editor und kehren Sie zu Ihrer Excel-Datei zurück. Klicken Sie auf “Makros” in der Registerkarte “Entwicklertools” und wählen Sie das Makro aus der Liste aus. Klicken Sie auf “Ausführen”, um das Makro auszuführen.

[Volkii]

Hallo DIZA,

super schnell und vielen Dank.

Es funktioniert.

Gruß
Volker

[RPP63]

Moin!
@Peter:
Unaufgefordert mal meine Sicht der Dinge:

Alle drei Vorschläge nutzen die Inputbox-Funktion, um den dort produzierten String in einen Integer/Long implizit umzuwandeln.
Das geht so lange gut, bis ein nicht als Zahl interpretierbarer Text eingegeben wird.

Sehr viel besser ist die Verwendung der Application.Inputbox-Methode!
Dort kann man durch Angabe von Type:=1 bereits vorgeben, dass nur ein zwingend als Zahl interpretierbarer Text übergeben werden kann.
(evtl. Nachkommastellen werden durch Übergabe an Integer/Long gerundet)

Thema Fehlerbehandlung:
• DIZA verwendet keine
• Chat GPT nutzt On Error Resume Next
• Bing nutzt es ebenfalls, die schreiben wohl voneinander ab … 
Beide werten einen evtl. Fehler aus, brechen aber als Folge das Makro rigoros ab, warum auch immer.

Falsch ist kein Code, am besten gefällt mir persönlich noch der von Bing.
Bing und Chat GPT verwenden Kommentare im Code.
Dies ist für Anfänger sinnvoll, wird von "echten" Helfern aber höchst selten gemacht, da zu zeitaufwändig.

Thema Variablen:
Sie machen den Code lesbarer.
Chat GPT übertreibt "ein wenig".
Ich persönlich finde Variablen nur dann sinnvoll, wenn sie variabel sind.
(heißt: wenn sie mehrfach im Code neu zugewiesen werden)

Mein Vorschlag (sicherlich auch nicht der Stein der Weisen):

Code:

Sub New_Sheets()
Dim i&
Application.ScreenUpdating = False
For i = 1 To Application.InputBox("Anzahl:", Type:=1)
  On Error Resume Next
  Worksheets("Template").Copy After:=Sheets(Sheets.Count)
  Sheets(Sheets.Count).Name = Format(i, "000")
  If Err.Number Then
    MsgBox "Das Blatt " & Format(i, "000") & "existiert bereits und wird nicht erstellt!"
    Application.DisplayAlerts = False
    Sheets(Sheets.Count).Delete
    On Error GoTo 0
  End If
Next
End Sub

Gruß Ralf

[Peter]

Hallo Ralf,

danke für deinen Kommentar - das ist für mich als Nicht-VBAler aufschlussreich.

Ich hätte den Code nicht gepostet wenn nicht schon eine andere funktionierende Lösung vorhanden gewesen wäre. Ich konnte zwar austesten, dass der Code funktioniert, aber ich kann, wie bereits geschrieben, die Qualität des Codes nicht einschätzen. Für mich war das einfach ein Versuch herauszufinden was mit KI aktuell möglich ist, wobei ich mir auch darüber im klaren bin, dass die Ausgangsaufgabe VBA-mässig nicht sonderlich anspruchsvoll ist.

Ich habe das Ausgangsposting

ich habe eine Excel Datei (M365) mit mehreren Arbeitsblättern. Ein Blatt heißt "TEMPLATE". Dieses Blatt möchte ich jetzt per MARKO x mal kopieren und zeitgleich fortlaufend umbenennen in "001", "002", "003" und so weiter.

ChatGPT so zum Fraß geworfen und der der erste Code den mir ChatGPT ausgegeben hat war dieser:

Code:

Sub CopyAndRename()
Dim i As Integer
Dim ws As Worksheet
Dim newWs As Worksheet

Set ws = Sheets("TEMPLATE")

For i = 1 To x
    ws.Copy After:=Sheets(Sheets.Count)
    Set newWs = ActiveSheet
    newWs.Name = Format(i, "000")
Next i

End Sub

Im weiteren Verlauf habe ich noch Ergänzungen zu der ersten Anweisung verlangt, deswegen auch:

Thema Fehlerbehandlung

Das habe ich so gewünscht: "Ergänze den Code um eine Fehlerbehandlung wenn ein Tabellenblatt bereits vorhanden ist"

Beide werten einen evtl. Fehler aus, brechen aber als Folge das Makro rigoros ab, warum auch immer.

Weil ich das so definiert habe: "Wenn das Tabellenblatt vorhanden ist soll eine entsprechende Hinweismeldung kommen und der VBA-Code soll beendet werden"

Bing und Chat GPT verwenden Kommentare im Code.

Auch das habe ich verlangt: "Kommentiere im Code die einzelnen Befehle"

(sicherlich auch nicht der Stein der Weisen)

Gibt es den überhaupt? Ich könnte mir vorstellen wenn du 5 VBA-Experten die Ausgangsaufgabe gibst bekommst du auch 5 verschiedene Codes.

Ist vermutlich ähnlich wie bei den Formellösungen - da bin ich auch immer wieder über die Bandbreite der Vorschläge erstaunt.

[EarlFred]

Ich könnte mir vorstellen wenn du 5 VBA-Experten die Ausgangsaufgabe gibst bekommst du auch 5 verschiedene Codes.

Eine der wichtigsten Unterschiede: Einige Codes provozieren Fehler, korrigieren dann die fehlerhaften Schritte und probieren es erneut. Andere prüfen vorher, ob das Blatt schon existiert und wenn ja, tun sie halt nichts und fahren mit dem nächsten fort. Letzteres halte ich für sauberer: Alles, was prüfbar ist, sollte geprüft werden, bevor man etwas tut. Try&Error kann man dann den Situationen vorbehalten, wo man nicht alle Eventualitäten vorher prüfen kann. 
Um die freien Nummern effizienter zu prüfen, kann man auch ein Dictionary mit den Blattnamen vorhalten, das spart die zwangsweise wiederholte Prüfung aller (immer mehr werdender) Blätter.

[RPP63]

Ist schon erstaunlich, aus

Dieses Blatt möchte ich jetzt per MARKO x mal kopieren

macht GPT das völlig unbrauchbare (da x nicht deklariert und vor allem nicht gefüllt ist):
For i = 1 To x
(aber der allseits bekannte Marko wird korrigiert )

Ich habe mal als Fingerübung ein "echtes" Programm geschrieben.
Das dürfte die KI so wohl eher nicht hinbekommen.

Ausgangsposition:
Es existieren bereits die Blätter 001, 003 und 005
Ich habe die Tabs mal rot eingefärbt.
   

Aufgabe:
Erstelle 6 Kopien von "Template", gibt mir die bereits vorhandenen Blattnamen als Meldung aus und sortiere als Abschluss die Blätter nach Namen.
Das Blatt "Template" soll weiterhin links stehen.

Der (jetzt natürlich umfangreichere) Code:

Sub New_Sheets()

Dim i&, k&, arr(), Existing_Sheets$

With Application

  .ScreenUpdating = False

  For i = 1 To .InputBox("Anzahl:", Type:=1)

    On Error Resume Next

    Worksheets("Template").Copy After:=Sheets(Sheets.Count)

    Sheets(Sheets.Count).Name = Format(i, "000")

    If Err.Number Then

      Redim Preserve arr(k)

      arr(k) = Format(i, "000")

      k = k + 1

      .DisplayAlerts = False

      Sheets(Sheets.Count).Delete

      On Error GoTo 0

    End If

  Next

  If k Then

    For i = 0 To k

      Existing_Sheets = Existing_Sheets & vbLf & arr(i)

    Next

    .ScreenUpdating = True

    MsgBox "folgende Blätter existierten bereits" & vbLf & _

            "und wurden nicht neu erstellt:" & vbLf & _

            Existing_Sheets & vbLf & vbLf & _

            "Die Blätter werden jetzt neu sortiert!"

    .ScreenUpdating = False

    For i = 1 To Sheets.Count - 1

      For k = i + 1 To Sheets.Count

          If Sheets(k).Name < Sheets(i).Name Then

              Sheets(k).Move Before:=Sheets(i)

          End If

      Next

    Next

    Sheets("Template").Move Before:=Sheets(1)

  End If

End With

End Sub

Zwischenstand bei Ausgabe der Meldung:
   

Ergebnis:
   

[EarlFred]

Ich habe mal als Fingerübung ein "echtes" Programm geschrieben.

Das kann nicht sein: Echte Programme nutzen kein On Error Resume Next, schon garnicht wahllos auf komplette Blöcke… *duckundweg*

[RPP63]

Bleib ruhig da!
Ich persönlich bin schon der Meinung, dass man On Error Resume Next bei erwartbaren Fehlern nutzen darf, wenn man es denn wie bei mir zurücksetzt.

Aber natürlich geht es auch ohne:

Sub New_Sheets()
Dim i&, k&, arr(), Existing_Sheets$
With Application
  .ScreenUpdating = False
  For i = 1 To .InputBox("Anzahl:", Type:=1)
    If SheetMissing(Format(i, "000")) Then
      Worksheets("Template").Copy After:=Sheets(Sheets.Count)
      Sheets(Sheets.Count).Name = Format(i, "000")
    Else
      Redim Preserve arr(k)
      arr(k) = Format(i, "000")
      k = k + 1
    End If
  Next
  If k Then
    For i = 0 To Ubound(arr)
      Existing_Sheets = Existing_Sheets & vbLf & arr(i)
    Next
    .ScreenUpdating = True
    MsgBox "folgende Blätter existierten bereits" & vbLf & _
            "und wurden nicht neu erstellt:" & vbLf & _
            Existing_Sheets & vbLf & vbLf & _
            "Die Blätter werden jetzt neu sortiert!"
    .ScreenUpdating = False
    For i = 1 To Sheets.Count - 1
      For k = i + 1 To Sheets.Count
          If Sheets(k).Name < Sheets(i).Name Then
              Sheets(k).Move Before:=Sheets(i)
          End If
      Next
    Next
    Sheets("Template").Move Before:=Sheets(1)
  End If
End With
End Sub

Function SheetMissing(ShName$) As Boolean
Dim ws As Worksheet
On Error GoTo HandleError
  Set ws = Sheets(ShName)
  SheetMissing = False
  Exit Function
HandleError:
  SheetMissing = True
End Function