Tabellenblätter erzeugen: Anhand Liste und verschiedener Vorlagen erstellen

[Thermes]

Hallo zusammen

Als Neuling hier Vorab:
Bin zwar "ziemlich fit" auch in Excel, vor allem Formeltechnisch.
Meine Kernkompetenzen liegt aber def. in "realen Formeln" aus dem Physikbereich (Thermo-/Hydrodynamik).

Einiges zu wenig VBA Kenntnisse - nachfolgendes def. zu Komplex - verzweifle an der Aufgabe:

Datei enthält Tabellenblätter:
- Liste mit Objekten ['Objekte']:
  jedes Objekt wird auf einer Zeile eingetragen
  Objekt-Art definiert jeweils aus Einträgen in 2 Spalten [C;D], Auswahlmöglichkeiten per Datenprüfung
- Vorlagenblatt je mögliche Objekt-Art [z.B. 'Lüftung Monobloc' oder 'MSRL':
  Per Makro sollen aus diesen dann Tabellenblätter aufgrund Objektliste erstellt werden
- Ausserdem die Blätter ['Titelblatt'] und ['Bemerkungen']
Diese sind aber nebensächlich, nur für die zweite kleine Aufgabe von Belang


Wenn nun die Liste ausgefüllt wurde, soll je Objekt 1 Tabellenblatt erstellt werden (per Makro).
- Blattname Anhand Objektliste Spalten C+D
- Überprüfung mit Info/Meldungsbox wenn Blatt schon vorhanden
- Vorlagen ggf. verstecken, einfach nur ausgeblendet mit Schutz ohne PW reicht aber auch

Zusatzaufgabe: Dann die Blätter Titelblatt, Bemerkungen, Objektliste sowie die erstellten Objektblätter drucken

Anbei die Datei, ohne kaum "gscheit" zu veranschaulichen ;-P


Schon mal besten Dank den VBA-Genies! ;)

[Thermes]

Hab die Datei etwas angepasst besser verständlich hoffe ich.

ausserdem wohl "einfacher" wenn zu erzeugende Blätter klar gesteuert in
Blatt = 1 Zeile / Vorlageauswahl = 1 Spalte

Nochmal die Problemstellung zusammen gefasst:
Es sollen automatisch Tabellenblätter erstellt werden, aufgrund einer Liste Tabellenblatt 'Objekte' (bestimmte wenn ausgefüllte Zeilen da)
Schwierigkeiten:
Mehrere Vorlagetypen (aufgrund Definition in 'Objekte'-Liste, Spalte C).
Prüfung auf schon vorhanden (dann Info/Meldungs-Box)
Funktion Drucken nur der Blätter welche in Liste Blatt 'Objekte' bei Spalte "I" mit x gewählt

Hoffe man versteht's :)

[Fennek]

Hallo,

Radio Erivan läßt grüßen: im Prinzip ist es recht einfach.

Aber:

Die Namen der Vorlagen-Sheets sollten identisch sein mit den Namen im Blatt "Objekte".

1. Fehler: Lüftung Monobloc OHNE "k" am Ende
2. Fehler = Abruch
    die Blattnamen nutzen das Zeichen Ascii 183 anstelle eines Leerzeichens

Vielleicht findet sich doch noch jemand, angesehen haben das Thema relativ viele.

mfg

[Thermes]

Radio Erivan?
Fehler war versehentlich (das k), und Leerzeichen oder ASCII0183 im Blattnamen müssen nicht zwingend sein ;)
Wie würden den die codes aussehen? ("Blätter erstellen" und "gewählte drucken") aussehen?

[schauan]

Hallöchen,

nur zum Blätter erstellen würde der Code unten gehen. Allerdings berücksichtigt das keine Vorlagetypen, da nicht klar ersichtlich ist, was nun eigentlich ein "Blatt" ist und was eine Vorlage. Wenn in Spalte M die Namen "Blättern" zuzuordnen sind, die genau so heißen wie die Vorlage, dann kann ich schlecht ein neues Blatt mit dem gleichen Namen erzeugen. Das ginge nur in einer neuen Datei.

Andererseits ist fraglich, zu welcher Vorlage die Blätter gehören, die es nur in Spalte M gibt.... Hier also erst mal der Code, der diese leeren Blätter erzeugt.

Code:

Sub BlaetterErstellen()
'Variablendeklarationen
'Integer, String
Dim iCnt%, strMsg$
'Mit dem Blatt Objekte
With Sheets("Objekte")
'Schleife ueber alle Eintraege in Spalte M ab Zeile 5
For iCnt = 5 To .Cells(Rows.Count, 13).End(xlUp).Row
  'Wenn das Blatt schon existiert, dann
  If SheetExist(.Cells(iCnt, 13)) Then
    'Name zu Meldung hinzufuegen
    strMsg = strMsg & vbLf & .Cells(iCnt, 13)
  'Alternativ zu Wenn das Blatt schon existiert, dann
  Else
    'Blatt hinzufuegen
    Sheets.Add
    'Name entsprechend Liste aendern
    ActiveSheet.Name = .Cells(iCnt, 13)
  'Ende Wenn das Blatt schon existiert, dann
  End If
'Schleife ueber alle Eintraege in Spalte M ab Zeile 5
Next
If strMsg <> "" Then MsgBox "Blätter schon vorhanden:" & strMsg
End Sub

Private Function SheetExist(ByVal strName As String) As Boolean
'Gehe bei Fehler zu Fehlerbehandlung
On Error Resume Next
'Bei Namensgleichheit Rueckgabewert auf Wahr setzen
SheetExist = (Sheets(strName).Name = strName)
End Function

[Thermes]

oh..Du hast natürlich recht (ergibt gleiche Tabellenblatt-Namen). Blöd von mir..

Könntest Du helfen wenn?:
- neue zu erzeugende Tabellenblätter Namen Anhand Spalte D im Blatt 'Objekte' bekommen sollen
- Die zu wählende Vorlage gewählt wird anhand Spalte C im Blatt 'Objekte'
(in Spalte M hab ich die Definition für die Eingabe mit Datenprüfung in Spalte C, damit eben nur da eingegeben werden kann was es wirklich gibt als "Vorlageblatt" (die Blätter rechts von 'Bemerkungen')
Ideal wäre es, wenn Makro so dass man auch nachträglich in 'Objekte' neue/zusätzliche Anlagen erfassen könnte, und dann trotzdem nur für die ein neues Blatt erstellt wird

Anbei Datei soweit aktualisiert/vorbereitet.

Wie bekomme ich hin das dann nur Blätter gedruckt werden?:
immer 'Titelblatt', 'Objekte', 'Bemerkungen' + erzeugte Blätter wenn in Blatt 'Objekte' (Übersicht) bei Spalte I ein "x" eingetragen.
hab da schon mal was versucht, in Datei anbei drinn

Könnten die "Vorlagenblätter" (also die Blätter rechts von 'Bemerkungen') ausgeblendet werden ohne Einfluss auf Makro zur Erzeugung neuer?


Schon mal ganz herzlichen Dank für das oben!

[schauan]

Hallöchen,

anbei der geänderte Code zum Erzeugen der Blätter. Den könntest Du z.B. auch über einen Button starten oder über die Auswertung des Ereignisses Worksheet_Change (siehe auch Deine Frage zu neuen Einträgen). Allerdings läuft der Code auf Fehler, wenn Du nicht erlaubte Zeichen im gewünschten Blattnamen hast. Nicht erlaubt sind
: / \ ? *
sowie am Anfang des Namens
'

Das könntest Du eventuell schon bei der Eingabe in Spalte D über eine Gültigkeitsregel verhindern.

Drucken kommt  noch.

Code:

Sub BlaetterErstellen()
'Variablendeklarationen
'Integer, String
Dim iCnt%, strMsg$
'Mit dem Blatt Objekte
With Sheets("Objekte")
 'Schleife ueber alle Eintraege in Spalte M ab Zeile 5
 For iCnt = 7 To .Cells(Rows.Count, 4).End(xlUp).Row
   'Wenn das Blatt schon existiert, dann
   If SheetExist(.Cells(iCnt, 4)) Then
     'Name zu Meldung hinzufuegen
     strMsg = strMsg & vbLf & .Cells(iCnt, 4)
     'Alternativ zu Wenn das Blatt schon existiert, dann
     Else
     'Blatt hinzufuegen
     Sheets(.Cells(iCnt, 3).Value).Copy After:=Sheets(Sheets.Count)
     'Name entsprechend Liste aendern
     ActiveSheet.Name = .Cells(iCnt, 4).Value
     'Ende Wenn das Blatt schon existiert, dann
   End If
   'Schleife ueber alle Eintraege in Spalte M ab Zeile 5
 Next
End With
If strMsg <> "" Then MsgBox "Blätter schon vorhanden:" & strMsg
End Sub

Private Function SheetExist(ByVal strName As String) As Boolean
'Gehe bei Fehler zu Fehlerbehandlung
On Error Resume Next
'Bei Namensgleichheit Rueckgabewert auf Wahr setzen
SheetExist = (Sheets(strName).Name = strName)
End Function

[schauan]

Hallöchen,

zum Drucken noch eine Frage.
In Deinem Code hast Du folgende Prüfung:

If ws.Range("AA1").Value = x Then

In der Frage schreibst DU aber, dass Du die in der Objektliste in Spalte I gekennzeichneten Blätter drucken willst.
Dazu würde folgender Ansatz passen:

Code:

...
'Mit dem Blatt Objekte
With Sheets("Objekte")
  'Schleife ueber alle Eintraege in Spalte M ab Zeile 5
  For iCnt = 7 To .Cells(Rows.Count, 4).End(xlUp).Row
    'Wenn in Spalte I ein x, dann
    If .Cells(iCnt, 9) = "x" Then
      ReDim Preserve varSelectedSheets(lngCounter)
      'Blattname aus Spalte D uebernehmen
      varSelectedSheets(lngCounter) = .Cells(iCnt, 4)
      lngCounter = lngCounter + 1
    'Ende Wenn in Spalte I ein x, dann
    End If
  'Ende Schleife ueber alle Eintraege in Spalte M ab Zeile 5
  Next
'Ende Mit dem Blatt Objekte
End With
...

[Thermes]

sieht sehr vielversprechend aus, krieg aber den/die Fehlermeldungen noch nicht weg.
wieso denn noch auf Spalte M / Zeile 5 prüfen gehen? glaube da liegt der knopf oder?
Müsste doch auf Spalte C ab zeile 7 gehen?
(nb: das in AA1 war nur geteste und eh nur abgriff von objektliste)

hier mal drinn, aber versteh noch nicht ganz alles resp. die Fehler

[Thermes]

Es sollen ja Blätter erstellt werden, Benannt Aufgrund Objektliste ['Objekte'] ab Zeile 7.
Benannt  nach Spalte D in 'Objekte', Vorlage auswählen aufgrund Spalte C in 'Objekte'

Was ist (noch) falsch?:

Code:

Sub BlaetterErstellen()
'Variablendeklarationen
'Integer, String
Dim iCnt%, strMsg$
'Mit dem Blatt Objekte
With Sheets("Objekte")
  'Schleife ueber alle Eintraege in Spalte D ab Zeile 7
 For iCnt = 7 To .Cells(Rows.Count, 4).End(xlUp).Row
    'Wenn das Blatt schon existiert, dann
   If SheetExist(.Cells(iCnt, 4)) Then
    'Name zu Meldung hinzufuegen
     strMsg = strMsg & vbLf & .Cells(iCnt, 4)
    'Alternativ zu Wenn das Blatt schon existiert, dann
     Else
    'Blatt hinzufuegen
     Sheets(.Cells(iCnt, 3).Value).Copy After:=Sheets(Sheets.Count)
    'Name entsprechend Liste aendern
     ActiveSheet.Name = .Cells(iCnt, 4).Value
    'Ende Wenn das Blatt schon existiert, dann
   End If
    'Schleife ueber alle Eintraege in Spalte D ab Zeile 7
 Next
End With
If strMsg <> "" Then MsgBox "Blätter schon vorhanden:" & strMsg
End Sub

Private Function SheetExist(ByVal strName As String) As Boolean
'Gehe bei Fehler zu Fehlerbehandlung
On Error Resume Next
'Bei Namensgleichheit Rueckgabewert auf Wahr setzen
SheetExist = (Sheets(strName).Name = strName)
End Function