Tabellenblätter nach Vorlage erstellen

24.05.2025 12:04:14

Jens

Hallo in die Runde,
ich möchte aus dem Tabellenblatt "MENÜKALKULATION" per Button neue Tabellenblätter erzeugen.
Dabei sollen die in Spalte E eingegeben Namen zum einen als Blattname verwendet werden und zum anderen in Zelle B2 als Überschrift.
Ich habe hier so einiges zu diesem Thema finden können krieg es aber nicht hin da etwas anzupassen das es funzt.
Leider habe ich von VBA nicht wirklich eine ahnung und hab mir jetzt sogar wie uch immer die Entwicklungsumgebung im VNA Explorer zerschossen.
Würde mich sehr über Hilfe nebst einer kurzen erklärung was da passsiert freuen.

Danke schonmal Jens

https://www.herber.de/bbs/user/177550.xlsm

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 13:14:44

Jens

den editor habe ich wieder hinbekommen und hier einen Code gefunden den ioch leider nicht angepasst bekomme.
'erstellt neues Tabellenblatt nach Vorlage
Sub neuesTabellenblatt()
Dim z, Na, ok
With Worksheets("Menükalkulation")
For z = 7 To 100
ok = True
Na = .Cells(z, 5)
If Na > "" Then
For Each Ws In ActiveWorkbook.Worksheets
Debug.Print Ws.Name
If Ws.Name = Na Then
ok = False
End If
Next
If ok Then
Worksheets("Vorlage").Copy After:=Worksheets("Menükalkulation")
ActiveSheet.Name = Na
Range("b2") = .Cells(z, 5)
Exit For
End If
Else
Exit Sub
End If
Next z
End With
End Sub

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 22:49:14

Uduuh

Hallo,
so geht das:

Sub KopiereBlatt()

  Dim rngC As Range

  Dim strGericht As String

  Dim wksNeu As Worksheet

  

  For Each rngC In Range(Cells(5, 5), Cells(Rows.Count, 5).End(xlUp)) 'Spalte E bis Ende durchgehen

    Set wksNeu = Nothing

    If rngC > "" Then  'Zelle nicht leer (falls Lücken sind)

    

      'Existiert das Blatt schon?

      On Error Resume Next

      Set wksNeu = Sheets(rngC.Value)

      On Error GoTo 0

      

      If wksNeu Is Nothing Then 'existiert noch nicht

        strGericht = rngC.Value    'Gericht merken

        Application.DisplayAlerts = False

        Sheets("Vorlage").Copy after:=Sheets(Sheets.Count)  'Blatt Vorlage kopieren

        With ActiveSheet

          .Name = strGericht           'umbenennen

          .Range("B2") = strGericht    'Gericht in B2 eintragen

        End With

        Application.DisplayAlerts = True

      End If

      

    End If

  Next rngC



End Sub

Gruß aus'm Pott
Udo

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 14:21:41

Piet

Hallo

die Vorlage habe ich ausgeblendet, sie kann unsichtbar im Hintergrund bleiben.
Die Tabelle18 (Menükalkulation) in Tabelle3 umbenannt. So stimmt die Reihenfolge.
Hinweis: Es kommt immer eine Abfrage nach Übernahme von Workbook Namen. Ist das Okay?
Unten der von mir verwendete und getestete Kopiercode.

mfg Piet

Sub KopiereBlatt()

Dim NewName As String, n&, lz1&

With Sheets("Menükalkulation")

    NewName = .Range("D2").Value

    'Prüfen ob Tabelle bereits vorhanden ist?

    For n = 4 To Worksheets.Count

      If Worksheets(n).Name = NewName Then _

         MsgBox "Diese Tabelle existiert schon!": Exit Sub

    Next n

    On Error GoTo Fehler

    'Vorlage kopiere

    Sheets("Vorlage").Copy after:=Sheets(Sheets.Count)

    'New Sheet sichtbar stellen

    With Sheets("Vorlage (2)")

         .Name = NewName & "_" & Sheets.Count

         .Visible = True

         .Select

         Range("B2").Select

    End With

End With

Exit Sub

Fehler: MsgBox "Vorlage kopieren fehlgeschlagen!"

End Sub

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 15:00:23

Jens

oh dankesehr probier ich gleich aus. Ja in der Vorlagesind dropdowns welche in die erzeugten Blätter übernommen werden sollen

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 15:07:24

Jens

da kommt bei mir die fehlermeldung das das anlegen fehlgeschlagen ist

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 15:18:37

Jens

Hallo erstmal Piet,
soviel zeit muss sein. Danke für die Unterstützung bis hier hin.
Also die Vorlage wird kopiert. Allerdings mit dem Blattnamen bzw der Überschrift das klappt leider nicht.
Die Bestätigung er Übernahme der Dropdowns sollte auch gleich mit passiern da diese benötigt werden.
Dazu habe ich einen applications Befehl gefunden ?

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 21:06:59

Jens

Hallo nochmal in die Runde. Nun hab ich den ganzen Tag rumprobiert und dies zustande gebracht.

Sub KopiereBlatt()
Sheets("Vorlage").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Select
BlattName = InputBox("Wie soll das Gericht heißen?")
ActiveSheet.Name = BlattName
End Sub

An sich ein Lösung die mir ganz gut gefällt und auch für diesen Zweck äußerst praktisch ist.
Nun kommt aber vor erscheinen der Abfrage wie das Gericht heißen soll eben die Frage ob die Namen übernommen werden sollen. Was bestätigt werden muß da diese übernommen werden sollen. Dies würde ich gern unterdrücken so das direkt die Abfrage nach dem Namen kommt. Dazua habe ich hier im Forum diesen Befehl gefunden

Sub KopiereBlatt()
Sheets("Vorlage").Copy After:=Sheets(Sheets.Count)
application.displayallerts = false
ActiveSheet.Select
BlattName = InputBox("Wie soll das Gericht heißen?")
ActiveSheet.Name = BlattName
End Sub

Leider gibt das dann wieder einen Fehler? Wie kann ich die Abfrage denn ünterdrücken?

Danke schonmal

Gruß Jens

AW: Tabellenblätter nach Vorlage erstellen

24.05.2025 22:52:49

Siegfried Freimann

Hallo,
versuche mal
Sub KopiereBlatt()

Dim NewName As String, n&, lz1&
With Sheets("Menükalkulation")
NewName = .Range("D2").Value
'Prüfen ob Tabelle bereits vorhanden ist?
For n = 4 To Worksheets.Count
If Worksheets(n).Name = NewName Then _
MsgBox "Diese Tabelle existiert schon!": Exit Sub
Next n
App_aus
On Error GoTo Fehler
'Vorlage kopiere
Sheets("Vorlage").Copy after:=Sheets(Sheets.Count)
'New Sheet sichtbar stellen
With Sheets("Vorlage (2)")
.Name = NewName & "_" & Sheets.Count
.Visible = True
.Select
Range("B2").Select
End With
App_aus
End With
Exit Sub
Fehler: MsgBox "Vorlage kopieren fehlgeschlagen!"
End Sub

Sub App_aus()
App_Status False
End Sub

Sub App_ein()
App_Status True
End Sub

Sub App_Status(ByVal Status As Boolean)
With Application
.EnableEvents = Status
.ScreenUpdating = Status
.DisplayAlerts = Status
.PrintCommunication = Status
If Status Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Sub
Gruß Sigi

AW: Tabellenblätter nach Vorlage erstellen

25.05.2025 00:17:16

Piet

Hallo

so läuft dein code bei mir ohne lästige Dialog Abfrage. Ich stelle die Inpubox gerne an den Anfang.
Bei der Syntac Eingabe bitte darauf achten ob Excel die Kleinschrift in -Großschrift- umwandelt!!
Dann wäre dir der Fehler mit application.displayallerts = false aufgefallen! 2x "ll" bei allerts!

mfg Piet

Sub KopiereBlatt()

BlattName = InputBox("Wie soll das Gericht heißen?")

Application.DisplayAlerts = False

Sheets("Vorlage").Copy After:=Sheets(Sheets.Count)

ActiveSheet.Select

ActiveSheet.Name = BlattName

End Sub

Tabellenblätter nach Vorlage erstellen

Forumthread: Tabellenblätter nach Vorlage erstellen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Tabellenblätter nach Vorlage erstellen

Forumthread: Tabellenblätter nach Vorlage erstellen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread