For Each NeueTabelle In Worksheets("Liste").Range("C5:D5").Value
Sub Erstellen()
For Each NeueTabelle In Worksheets("Liste").Range("C5:D5").Value
If Not IsEmpty(NeueTabelle) Then
Sheets("Muster").Copy After:=Sheets(Sheets.Count) 'Vorlagetabelle als letztes Blatt in die _
Arbeitsmappe kopieren
Application.DisplayAlerts = False 'Rückfrage (nach dem Löschen einer bestehenden Tabelle) _
unterdrücken
'Versuch, eine gleichnamige Tabelle zu löschen; bei Fehler (= Tabelle ohnehin nicht vorhanden) _
einfach weitermachen
On Error Resume Next: Sheets(NeueTabelle).Delete: On Error GoTo 0
Application.DisplayAlerts = True 'Systemeldungen wieder einschalten
Sheets(Sheets.Count).Name = NeueTabelle 'neue Tabelle (= letztes Blatt der Mappe) umbenennen
End If
Next
MsgBox "Fertig."
End Sub
Sub Erstellen()
Dim SP As Integer, ZE As Integer, LR As Long, i As Long
Dim NT As Worksheet, NeueTabelle As String
SP = 3 'Spalte C
ZE = 5 'ab Zeile
With Worksheets("Liste")
LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte C
For i = ZE To LR
If Not IsEmpty(.Cells(i, SP)) Then
NeueTabelle = .Cells(i, SP) & " " & .Cells(i, SP + 1)
Sheets("Muster").Copy After:=Sheets(Sheets.Count)
Set NT = ActiveSheet
Application.DisplayAlerts = False 'Rückfrage (nach dem Löschen einer bestehenden Tabelle) _
unterdrücken
'Versuch, eine gleichnamige Tabelle zu löschen; bei Fehler (= Tabelle ohnehin nicht vorhanden) _
einfach weitermachen
On Error Resume Next: Sheets(NeueTabelle).Delete: On Error GoTo 0
Application.DisplayAlerts = True 'Systemeldungen wieder einschalten
NT.Name = NeueTabelle 'neue Tabelle (= letztes Blatt der Mappe) umbenennen
End If
Next
End With
MsgBox "Fertig."
End Sub
Sub Erstellen()
Dim SP As Integer, ZE As Integer, LR As Long, i As Long
Dim NT As Worksheet, NeueTabelle As String
SP = 3 'Spalte C
ZE = 5 'ab Zeile
With Worksheets("Liste")
LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte C
For i = ZE To LR
If Not IsEmpty(.Cells(i, SP)) Then
NeueTabelle = .Cells(i, SP) & " " & .Cells(i, SP + 1)
Sheets("Muster").Copy After:=Sheets(Sheets.Count)
Set NT = ActiveSheet
Application.DisplayAlerts = False
On Error Resume Next: Sheets(NeueTabelle).Delete: On Error GoTo 0
Application.DisplayAlerts = True 'Systemeldungen wieder einschalten
NT.Name = NeueTabelle 'neue Tabelle (= letztes Blatt der Mappe) umbenennen
NT.Range("C4:M4").Value = .Range(.Cells(i, 3), .Cells(i, 13)).Value
End If
Next
End With
MsgBox "Fertig."
End Sub