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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen