Tabellenblätter variabel kopieren

Hallo zusammen,
folgender Sachverhalt:
Ich habe eine Tabelle mit insgesamt 4 Tabellenblättern (Anfrage, Üb., Mat., und Fert.)
Es werden in "Anfrage" Werte eingetragen. Hier gibt es die Möglichkeit, dass man mehrere Farben (erste Farbe in D29, zweite in E29,...) angeben kann. (max. 10 Stück)
Anhand dieser Anzahl der Farben sollen die Tabellenblätter Üb, Mat und Fert kopiert werden.
Sprich man gibt beispielsweise 3 Farben (rot, weiß und grün) an, dann sollen die Blätter Üb. rot, Mat. rot, Fert. rot, Üb. weiß, Mat. weiß, .... erstellt werden, bis alle Blätter für jede Farbe aus der Anfrage erstellt wurde.
Wollte wie folgt vorgehen:
1. Üb., Mat. und Fert. Kopie erstellen (Üb (1), Mat. (1) und Fert (1))
2. Üb(1) Mat (1) und Fert (1) umbenennen zu Üb rot, Mat rot und Fert rot
(erster Farbname)
3. Schritt 1 wiederholen
4. Schritt 2 wiederholen mit der nächsten Farbe aus "Anfrage"
5. so oft wiederholen bis alle Farben aus Anfrage abgedeckt sind.
Mein Problem ist, dass die Anzahl der Farbe sehr stark variiert, manchmal sind es zwei, manchmal sind es fünf oder teilweise auch nur eine Farbe.
Folgenden Code habe ich bisher:
'Üb kopieren
Sheets("Üb").Select
ActiveSheet.Buttons.Add(978.75, 995.25, 129, 31.5).Select
ActiveSheet.Buttons.Add(773.25, 1488.75, 204, 39.75).Select
Sheets("Üb").Copy Before:=Sheets(2)
'Erste Farbe kopieren
Sheets("Anfrage").Select
Range("D29").Select
Application.CutCopyMode = False
Selection.Copy
'Üb (1) umbenennen zu Üb + erster Farbname
Sheets("Üb (1)").Select
Sheets("Üb (1)").Name = "Üb "
Hoffe Ihr habt meine Anfrage einigermaßen verstanden und es kann mit jemand weiterhelfen.
Vielen Dank schon mal im voraus.
Gruß
David

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MeinProgramm() Application.ScreenUpdating = False Dim wsAnfrage As Worksheet, wsUb, wsMat, wsFert Dim rng As Range 'Tabellenblätter den Variablen zuordnen Set wsAnfrage = ThisWorkbook.Worksheets("Anfrage") Set wsUb = ThisWorkbook.Worksheets("Üb.") Set wsMat = ThisWorkbook.Worksheets("Mat.") Set wsFert = ThisWorkbook.Worksheets("Fert.") 'Jede Zelle in der Range von D29:M29 durchlaufen For Each rng In wsAnfrage.Range("D29:M29") 'Abfragen ob die Zelle nicht leer ist If Not IsEmpty(rng) Then 'Wenn die Zelle nicht leer ist, dann werden die drei Tabellenblätter (Üb., Mat. und _ Fert.) kopiert und mit dem Text, welcher in der Zelle steht, ergänzt wsUb.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsUb.Name & " " & rng.Text wsMat.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsMat.Name & " " & rng.Text wsFert.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsFert.Name & " " & rng.Text End If Next rng Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Tabellenblätter variabel kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread