Tabellen nach Liste, wenn noch nicht vorhanden

Forumthread: Tabellen nach Liste, wenn noch nicht vorhanden

07.09.2007 10:38:00

Jürgen

Hallo Profis,
eventuelle könnt Ihr mir weiterhelfen.
Unten aufgeführten tollen Codes habe ich im Archiv gefunden. Weis zwar nicht mehr wo, aber totzdem Dank an den (die) MacherIn. Durch diesen Codes werden neue Sheets entsprechend einer Liste angelegt. Die Tabelle "Vorlage" wird in jede neue Tabelle kopiert.
Nun möchte ich gern, dass nur Tabellen angelegt werden, die noch nicht vorhanden sind.
Hintergrund: Wenn die Liste in der Tabelle "Gesamtübersicht" verändert bzw. erweitert wird, dann kann mit dem gleichen Makro eine Aktualisierung erfolgen.
Hinweis: Überzählige Tabellen, außer "Gesamtübersicht" und "Vorlage", sollen entfernt werden. Bereits vorhandene Tabellen dürfen nicht mit dem Inhalt der Tabelle "Vorlage" überschrieben werden, es sei denn, es ist noch eine Abfrage eingebaut, ob die vorhandenen Tabellen mit "Vorlage" überschrieben werden sollen (Variante zum erstellen für neuen Monat).


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

Ich denke, das dieser Wunsch, durch Euch sicherlich schnell erfüllt werden kann und kein Problem darstellt, für mich, mit meinen bescheidenem Wissen, aber schon.
Danke schon mal in voraus!
Gruß Jürgen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Tabellen nach Liste, wenn noch nicht vorhanden

07.09.2007 12:26:00

ptonka

Hallo Jürgen,
bei mir klappt es mit einem "Unterprogramm":
Public Blattname As String


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

Gruß,
Jochen
P.S. Feedback ist für alle interessant

AW: Tabellen nach Liste, wenn noch nicht vorhanden

07.09.2007 14:38:00

Jürgen

Hallo Jochen,
vielen Dank für Deine Hilfe. Klappt auch zum Anlegen neuer Tabellen.
Es gibt aber noch ein kleines Problem und zwar werden, nach Veränderung der Namen und erneutem Ausführen des Makros, die Tabellenblätter mit den, in der Liste nicht mehr vorhandenen Namen nicht gelöscht.
Eventuelle hast Du auch noch eine Idee zur Abfrage, ob die schon vorhandenen Tabellen mit dem Inhalt der Vorlage überschrieben werden sollen oder nicht.
Aber nichts desto trotz war Deine schnelle Hilfe schon prima. Danke an dieser Stelle.
Gruß Jürgen

AW: Tabellen nach Liste, wenn noch nicht vorhanden

08.09.2007 00:30:06

fcs

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

AW: Tabellen nach Liste, wenn noch nicht vorhanden

10.09.2007 08:28:00

Jürgen

Hallo Franz,
Sorry, das ich erst jetzt antworte, aber ich war am Wochenende voll eingespannt (Hochzeitstag).
Dein Vorschlag ist wirklich super und trifft den Nagel auf den Kopf. Genau so sollte es sein.
Herzlichen Dank dafür. Besonders Klasse finde ich es, das Du den Codes teilweise kommentiert hast, so kann ich, mit meinen bescheidenen Kenntnissen, auch einiges nachvollziehen. Danke!
Dank an dieser Stelle auch an alle anderen Helfer in diesem Forum, die zu allen (un)möglichen Zeiten (man achte einfach mal auf die Zeiten von den Antworten) mit Ihrem Wissen helfen.
Gruß Jürgen

Beliebteste Forumthreads (12 Monate)

Tabellen nach Liste, wenn noch nicht vorhanden

Forumthread: Tabellen nach Liste, wenn noch nicht vorhanden

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Tabellen nach Liste, wenn noch nicht vorhanden

Forumthread: Tabellen nach Liste, wenn noch nicht vorhanden

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread