Variable Tabellblatterstellung

Hallo zusammen,
ich nehme hier Bezug auf diesen Archivierten Beitrag
https://www.herber.de/forum/archiv/1776to1780/t1776739.htm#1777851
Kurz zusammengefasst:
Das Dokument hat insgesamt 4 Tabellenblätter ("Anfrage" , "ÜB", "MAT", "FERT"). In der "Anfrage können Farbnamen, Farbnummern und Informationen bezüglich der Zuschnitte (ZS1 bis ZS4) eingetragen werden.
Hier mal ein Link zu einer Dummydatei
https://www.herber.de/bbs/user/139605.xlsx
Das Ziel des Codes soll es sein, die Tabellenblätter "ÜB", "MAT" und "FERT" für alle Farben und entsprechend für alle Zuschnitte kopieren.
Als Beispiel:
Farbe 1 (rot, Nr. 93645) und es befinden sich Informationen in ZS1 bis ZS4.
Dann sollen die Blätter nach dem folgenden Schema kopiert bzw erstellt werden.
"ÜB - 93645 - ZS1", "MAT - 93645 - ZS1", "FERT - 93645 - ZS1"
"ÜB - 93645 - ZS2", "MAT - 93645 - ZS2", "FERT - 93645 - ZS2"
"ÜB - 93645 - ZS3", "MAT - 93645 - ZS3", "FERT - 93645 - ZS3"
"ÜB - 93645 - ZS4", "MAT - 93645 - ZS4", "FERT - 93645 - ZS4"
Dies soll für alle Farben gemacht werden.
Folgenden Code habe ich freundlicherweise von Franz schon bekommen:

Sub AnfrageBlaetterKopieren()
Dim wsAnfrage As Worksheet, wsUeb As Worksheet, wsMat As Worksheet, wsFert As Worksheet
Dim rng As Range
Dim spaZS As Long, zeiZS As Long, StatusCalc As Long
Dim strZS As String, dblEuro As Double, dblStueck As Double, varZS_Nr As Variant
Dim wsZiel As Worksheet
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
zeiZS = 92 'Zeile mit Zuschnitt-Nummern
For Each Rng In wsAnfrage.Range("D33:M33")
bezZS = 94
spaSu = 50 'Zeile für die Gesamtsumme
spaPr = 55 'Zeile für den Preis
spaGE = 56 'Zeile für den Gewinn
If Not IsEmpty(Rng) Then
For spaZS = 5 To 11 Step 2
strZS = wsAnfrage.Cells(zeiZS, spaZS).Value
If wsAnfrage.Cells(zeiZS + 2, spaZS).Text  "" Then 'prüft, ob EURO-Betrag eingetragen  _
_
is
dblEuro = wsAnfrage.Cells(zeiZS + 2, spaZS).Value
dblStueck = wsAnfrage.Cells(zeiZS + 4, spaZS).Value
varZS_Nr = wsAnfrage.Cells(zeiZS + 6, spaZS).Value
wsUeb.Copy after:=Sheets(Sheets.Count)
Set wsZiel = ActiveSheet
With wsZiel
.Name = wsUeb.Name & " - " & Rng.Offset(-1, 0).Text & " - " & strZS
.Range("E61").Value = dblEuro
.Range("M8").Value = Rng.Offset(-1, 0).Text
For i = 4 To 14
'              .Range("H10").Value = wsAnfrage.Cells(spaSu, i).Value
'              .Range("H101").Value = wsAnfrage.Cells(spaPr, i).Value
'              .Range("P108").Value = wsAnfrage.Cells(spaGE, i).Value
'so werden die 11 Werte in die Zelle und die darunter liegenden Zellen eingetragen
.Range("H10").Offset(i - 4, 0).Value = wsAnfrage.Cells(spaSu, i).Value
.Range("H101").Offset(i - 4, 0).Value = wsAnfrage.Cells(spaPr, i).Value
.Range("P108").Offset(i - 4, 0).Value = wsAnfrage.Cells(spaGE, i).Value
'so werden die 11 Werte in die Zelle und die rechts daneben iegenden Zellen eingetragen
.Range("H10").Offset(0, i - 4).Value = wsAnfrage.Cells(spaSu, i).Value
.Range("H101").Offset(0, i - 4).Value = wsAnfrage.Cells(spaPr, i).Value
.Range("P108").Offset(0, i - 4).Value = wsAnfrage.Cells(spaGE, i).Value
Next i
End With
wsMat.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = wsMat.Name & " - " & Rng.Offset(-1, 0).Text & " - " & strZS
wsFert.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = wsFert.Name & " - " & Rng.Offset(-1, 0).Text & " - " & strZS
End If
Next spaZS
End If
Next Rng
Sheets("Anfrage").Select
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Leider befinden sich in dem Code noch zwei Probleme und ich bin mit meinem Latein am Ende und weiß nicht, wie ich es lösen kann.
-> Der Code läuft nicht, wenn keine Angaben in den Feldern für ZS1 bis ZS4 steht. Wenn hier keine Informationen stehen, soll der Code die Tabellenblätter "ÜB", "MAT" und "FERT"
für die erste Farbe erstellen und dann die nächste Farbe auswählen.
-> Die Schleife mit dem i funktioniert leider nur bedingt, es werden alle Anweisungen mit dem i abgearbeitet, bevor das nächste Tabellenblatt erstellt wird.
Es sollte allerdings so laufen, dass für das erste Blatt "ÜB" die ersten Werte aus der i-Schleife verwendet werden und beim nächsten "ÜB" Blatt dann die nächsten.
Hierbei ist noch zustätzlich anzumerken, dass falls es ZS1 bis ZS4 gibt und bspw. zwei Farben, dann soll der erste i-Wert für ZS1 - 4 Farbe eins gelten und der zweite i-Wert
dann für ZS1 bis ZS4 Farbe zwei.
Das ganze ist ein wenig kompliziert, ich hoffe ich konnte es dennoch einigermaßen verständlich erklären.
Für Fragen stehe ich zur Verfügung!
Vielen Dank schon ein mal im Voraus!
Gruß
David

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub AnfrageBlaetterKopieren() Dim wsAnfrage As Worksheet, wsUeb As Worksheet, wsMat As Worksheet, wsFert As Worksheet Dim rng As Range Dim spaZS As Long, zeiZS As Long, StatusCalc As Long Dim strZS As String, dblEuro As Double, dblStueck As Double, varZS_Nr As Variant Dim wsZiel As Worksheet With Application .ScreenUpdating = False StatusCalc = .Calculation .Calculation = xlCalculationManual End With zeiZS = 92 'Zeile mit Zuschnitt-Nummern For Each rng In wsAnfrage.Range("D33:M33") bezZS = 94 spaSu = 50 'Zeile für die Gesamtsumme spaPr = 55 'Zeile für den Preis spaGE = 56 'Zeile für den Gewinn If Not IsEmpty(rng) Then For spaZS = 5 To 11 Step 2 strZS = wsAnfrage.Cells(zeiZS, spaZS).Value If wsAnfrage.Cells(zeiZS + 2, spaZS).Text "" Or strZS = "" Then 'prüft, ob EURO- _ Betrag eingetragen ist dblEuro = wsAnfrage.Cells(zeiZS + 2, spaZS).Value dblStueck = wsAnfrage.Cells(zeiZS + 4, spaZS).Value varZS_Nr = wsAnfrage.Cells(zeiZS + 6, spaZS).Value wsUeb.Copy after:=Sheets(Sheets.Count) Set wsZiel = ActiveSheet With wsZiel .Name = wsUeb.Name & " - " & rng.Offset(-1, 0).Text & IIf(strZS = "", "", " - " & _ strZS) .Range("E61").Value = dblEuro .Range("M8").Value = rng.Offset(-1, 0).Text i = 4 + (spaZS - 5) / 2 .Range("H10").Value = wsAnfrage.Cells(spaSu, i).Value .Range("H101").Value = wsAnfrage.Cells(spaPr, i).Value .Range("P108").Value = wsAnfrage.Cells(spaGE, i).Value End With wsMat.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsMat.Name & " - " & rng.Offset(-1, 0).Text & _ IIf(strZS = "", "", " - " & strZS) wsFert.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsFert.Name & " - " & rng.Offset(-1, 0).Text & _ IIf(strZS = "", "", " - " & strZS) End If If strZS = "" Then Exit For Next spaZS End If Next rng Sheets("Anfrage").Select With Application .ScreenUpdating = True .Calculation = StatusCalc End With End Sub

Guten Morgen Franz,
vielen Dank für deinen Code. Habe den mal getestet und folgendes festgestellt:
- Wenn in den -Werten für die Zuschnitte nichts steht (E, G, I und K94) nicht steht, allerdings soll der Code dann ja die Zuschnitte nicht beachten sondern lediglich die Blätter "ÜB", "MAT" und "FERT" für die Farben erstellen.
- Die Werte welche mit der i-Variable verknüpft sind und kopiert und eingefügt werden passen nicht ganz, da wenn Zuschnitte vorhanden sind, die Werte für alle Zuschnitte je Farbe identisch sind. Mal angenommen in D50 steht 1300 und in E50 2100. Dann sollen bei allen ZS (falls vorhanden) für die erste Farbe 1300 bei "ÜB - Farbnummer1 - Zuschnittsnummer" H10 die 1300 stehen. Aktuell wird das quasi nur bei "ÜB - Farbnummer1 - ZS1" übernommen und bei "ÜB - Farbnummer1 - ZS2" kommt in H10 2100 als Wert.
Vorab schon ein mal dir vielen Dank!
Gruß
David
P.S. Spielt es für den Code eine Rolle, ob er in einem Modul eingefügt wird oder in einem entsprechenden Tabellenblatt?

Sub AnfrageBlaetterKopieren() Dim wsAnfrage As Worksheet, wsUeb As Worksheet, wsMat As Worksheet, wsFert As Worksheet Dim rng As Range Dim spaZS As Long, zeiZS As Long, StatusCalc As Long Dim strZS As String, dblEuro As Double, dblStueck As Double, varZS_Nr As Variant Dim wsZiel As Worksheet Dim i As Integer Dim bezZS, spaSu, spaPr, spaGE If MsgBox("Kalkulationblätter für Anfrage jetzt anlegen?", vbOKCancel + vbQuestion, _ "A N F R A G E B L Ä T T E R K O P I E R E N") = vbCancel Then Exit Sub With Application .ScreenUpdating = False StatusCalc = .Calculation .Calculation = xlCalculationManual End With zeiZS = 92 'Zeile mit Zuschnitt-Nummern i = 4 'Spalte für 1. Farbe Set wsAnfrage = ActiveWorkbook.Worksheets("Anfrage") Set wsUeb = ActiveWorkbook.Worksheets("ÜB") Set wsMat = ActiveWorkbook.Worksheets("MAT") Set wsFert = ActiveWorkbook.Worksheets("FERT") For Each rng In wsAnfrage.Range("D33:M33") bezZS = 94 spaSu = 50 'Zeile für die Gesamtsumme spaPr = 55 'Zeile für den Preis spaGE = 56 'Zeile für den Gewinn i = rng.Column If Not IsEmpty(rng) Then For spaZS = 5 To 11 Step 2 strZS = wsAnfrage.Cells(zeiZS, spaZS).Value If wsAnfrage.Cells(zeiZS + 2, spaZS).Text "" Then 'prüft, ob EURO-Betrag eingetragen _ ist 'EURO-Wert ist eingetragen dblEuro = wsAnfrage.Cells(zeiZS + 2, spaZS).Value dblStueck = wsAnfrage.Cells(zeiZS + 4, spaZS).Value varZS_Nr = wsAnfrage.Cells(zeiZS + 6, spaZS).Value wsUeb.Copy after:=Sheets(Sheets.Count) Set wsZiel = ActiveSheet With wsZiel .Name = wsUeb.Name & " - " & rng.Offset(-1, 0).Text & strZS .Range("E61").Value = dblEuro .Range("M8").Value = rng.Offset(-1, 0).Text .Range("H10").Value = wsAnfrage.Cells(spaSu, i).Value .Range("H101").Value = wsAnfrage.Cells(spaPr, i).Value .Range("P108").Value = wsAnfrage.Cells(spaGE, i).Value End With wsMat.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsMat.Name & " - " & rng.Offset(-1, 0).Text & strZS wsFert.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsFert.Name & " - " & rng.Offset(-1, 0).Text & strZS Else 'kein EURO-Wert eingetragen - ZS-Werte ignorieren wsUeb.Copy after:=Sheets(Sheets.Count) Set wsZiel = ActiveSheet With wsZiel .Name = wsUeb.Name & " - " & rng.Offset(-1, 0).Text End With wsMat.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsMat.Name & " - " & rng.Offset(-1, 0).Text wsFert.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = wsFert.Name & " - " & rng.Offset(-1, 0).Text Exit For End If Next spaZS End If Next rng Sheets("Anfrage").Select With Application .ScreenUpdating = True .Calculation = StatusCalc End With End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread