Tabellen nach Liste, wenn noch nicht vorhanden

Sub Blätter_erstellen() Dim laR As Long, i As Long Application.ScreenUpdating = False With Sheets("Gesamtübersicht") laR = .Cells(Rows.Count, 8).End(xlUp).Row 'If laR > 15 Then laR = 15 ' benötige ich nicht, da Liste nach unten offen ist For i = 8 To laR If .Cells(i, 4) "" Then Sheets("Vorlage").Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = .Cells(i, 4) End If Next i End With Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Blätter_erstellen() Dim laR As Long, i As Long Application.ScreenUpdating = False With Sheets("Tabelle3") laR = .Cells(Rows.Count, 8).End(xlUp).Row 'If laR > 15 Then laR = 15 ' benötige ich nicht, da Liste nach unten offen ist For i = 8 To laR If .Cells(i, 4) "" Then Sheets("Vorlage").Copy After:=Sheets(Sheets.Count) Blattname = .Cells(i, 4).Value Call neuesBlatt End If Next i End With Application.ScreenUpdating = True End Sub

Sub neuesBlatt() On Error GoTo weiter Sheets(Sheets.Count).Name = Blattname GoTo weiter2 weiter: Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True weiter2: End Sub

Hallo Jürgen,
hier mein Vorschlag. Er beinhaltet eine Meldung in der das Überschreiben (genauer das Ersetzen) der vorhandenen Blätter gewählt werden kann.
Gruß
Franz


Sub Blätter_erstellen()
Dim laR As Long, i As Long, ueberschreiben As Long, Blatt, loeschen As Boolean
Application.ScreenUpdating = False
ueberschreiben = MsgBox("Vorhandene Blätter durch Vorlage ersetzen?", _
vbQuestion + vbYesNoCancel + vbDefaultButton2, "Tabellenblätter erstellen")
If ueberschreiben = vbCancel Then Exit Sub
With Sheets("Gesamtübersicht")
laR = .Cells(Rows.Count, 8).End(xlUp).Row
If ueberschreiben = vbYes Then
'Vorhandene Blätter löschen, da sie durch Vorlage ersetzt werden sollen
For Each Blatt In ActiveWorkbook.Sheets
Select Case Blatt.Name
Case "Vorlage", "Gesamtübersicht" 'Liste der Ausnahmen
'do nothing
Case Else
Application.DisplayAlerts = False
Blatt.Delete
Application.DisplayAlerts = True
End Select
Next
End If
'Überzählige Blätter (nicht in Liste vorhanden) löschen
For Each Blatt In ActiveWorkbook.Sheets
Select Case Blatt.Name
Case "Vorlage", "Gesamtübersicht" 'Liste der Ausnahmen
'do nothing
Case Else
loeschen = True
For i = 8 To laR
If .Cells(i, 4) = Blatt.Name Then
loeschen = False
Exit For
End If
Next i
If loeschen = True Then
Application.DisplayAlerts = False
Blatt.Delete
Application.DisplayAlerts = True
End If
End Select
Next
'Neue Blätter als Kopie von Blatt Vorlage anfügen
For i = 8 To laR
If .Cells(i, 4)  "" Then
If Blattcheck(ActiveWorkbook, .Cells(i, 4)) = False Then
ActiveWorkbook.Sheets("Vorlage").Copy After:=Sheets(Sheets.Count)
ActiveWorkbook.Sheets(Sheets.Count).Name = .Cells(i, 4)
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Private Function Blattcheck(wbWorkbook As Workbook, strBlatt$) As Boolean
'Prüft ob Blattname in wbWorkbook schon vorhanden
Dim Blatt As Object
Blattcheck = False
For Each Blatt In wbWorkbook.Sheets
If Blatt.Name = strBlatt Then
Blattcheck = True
Exit For
End If
Next
End Function

Beliebteste Forumthreads (12 Monate)

Tabellen nach Liste, wenn noch nicht vorhanden

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

215 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellen nach Liste, wenn noch nicht vorhanden

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

215 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread