Makro inkl. Seitenlayouts

[RPP63]

1. Der Code gehört in ein allgemeines Modul (Einfügen, Modul)
2. Dein Blatt mit dem Inhaltsverzeichnis heißt Themen.

Ich habe die Vorlage jetzt mal ausgeblendet und das Blatt "Inhalt" entfernt.

Datei im Anhang.

Gruß Ralf

[Michael_91]

Genau so sollte es sein!!!

DANKE

[Michael_91]

Kann man jetzt auch noch sagen, dass dieser Name der Tabelle immer als Überschrift auch in der Vorlage erscheint?

Also so hat jedes neue Tabellenblatt die Überschrift gleich wie die Beschriftung.

[RPP63]

Dann erweitere das Makro wie folgt:

Sub FuegeBlaetterMitNamenEin()
Dim Zelle As Range
Application.ScreenUpdating = False
With Worksheets("Vorlage")
  .Visible = True
  For Each Zelle In Worksheets("Themen").Range("A1:A6")
     .Copy After:=Sheets(Sheets.Count)
     With ActiveSheet
      .Name = Zelle
      .Range("A1") = Zelle
     End With
  Next
  .Visible = False
End With
End Sub

Gruß Ralf

[Michael_91]

Das passt nun alles super!
Aber vielleicht könnte es noch ein bisschen perfekter werden.

Wenn ich bereits einige neue Tabellen mithilfe des Makros erzeugt habe und mir dann noch
etwas einfällt und ich die Liste ergänze und dann wieder das Makro aufrufe, kommt eine
Fehlermeldung, dass es diese Namen bereits gibt.

Kann man da sowas einbauen, dass die vorhandenen ignoriert werden und trotzdem die
Neuen Tabellen erzeugt werden?

[RPP63]

Moin mal wieder!
Und schon sind wir wieder bei meinem ersten Beitrag (#2).
Eigenzitat:

Aber Achtung!
Tabellenblätter haben gewisse Konventionen.
(Länge, Sonderzeichen, keine doppelten Namen)
Daher muss eine vernünftige Fehlerbehandlung eingearbeitet werden.

Jetzt wieder zu Dir:

Kann man da sowas einbauen, dass die vorhandenen ignoriert werden und trotzdem die
Neuen Tabellen erzeugt werden?

Ja man kann vor dem Kopiervorgang der Vorlage überprüfen, ob es bereits ein Blatt mit dem Namen gibt.
Ich mache dies mit einer UDF, die einen boolean-Wert (True oder False) zurückgibt.

Function SheetExists(sBook, sName) As Boolean
Dim x As Worksheet
On Error Resume Next
   Set x = Workbooks(sBook).Sheets(sName)
   If Err = 0 Then SheetExists = True
End Function

Hilft Dir dies bereits?  :21:
(Ich schreibe aber gleich ein wenig mehr dazu …)

Gruß Ralf

[RPP63]

Hier jetzt vollständig.
Fängt auch nicht erlaubte Tabellennamen ab:

Modul Modul1

Option Explicit 
 
Sub FuegeBlaetterMitNamenEin() 
Dim Zelle As Range 
Application.ScreenUpdating = False 
With Worksheets("Vorlage") 
   .Visible = True 
   For Each Zelle In Worksheets("Themen").Range(Range("A1"), Range("A1").End(xlDown)) 
      If Not SheetExists(Zelle.Text) Then 
         .Copy After:=Sheets(Sheets.Count) 
         With ActiveSheet 
            .Name = Zelle 
            .Range("A1") = Zelle 
         End With 
      End If 
   Next 
   .Visible = False 
End With 
End Sub 
 
Function SheetExists(sName) As Boolean 
Dim x As Worksheet 
On Error Resume Next 
   Set x = Worksheets(sName) 
   If Err = 0 Then SheetExists = True 
End Function 

Gruß Ralf

[Michael_91]

DANKE! Klappt wunderbar!!