Kopieren von Zellbereich mithilfe einer Beding.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Schönen Guten Morgen,
habe jetzt mal eine Musterdatei hochgeladen.
Es sieht folgendermaßen aus. Im Tabellenblatt "Zyklendefinition" befindet sich die Matrix, bestehend aus Einsen. Ich möchte mit dem Makro einen s.g. Gesamtzyklus generieren. Ein Zyklus besteht dabei aus mehreren Betriebspunkten (BP_01-12). Ab einer gewissen Zykluszahlen fallen jedoch ein paar Betriebspunkte weg (sobald in einer Zelle keine Eins eingetrage ist, fällt der BP weg). In dem Beispiel ab Zyklus Nr. 09. Am Ende werden es natürlich deutlich mehr Zyklen werden.
Das Makro sollte nun, beginnend in Zelle B3, prüfen ob einen Eins eingetragen ist oder nicht. Wenn bespielsweise in B3 eine Eins steht, soll aus dem Tabellenblatt "Betriebspunktdefinition" der entsprechende Zellebereich in das Tabellenblatt "Gesamtzyklus" kopiert werden. Im Tabellenblatt "Betriebspunktdefinitionen" gibt es für jeden BP einen Zellbereich BP_01-12. Wenn nun in der Matrix bei BP_11 einen 1 steht, soll der Zellbereich A53:G56 kopiert werden.
Dabei ist es entscheidend, dass das Makro Spalte für Spalte und von oben nach unten abfragt. Zudem ist es erforderlich, dass die kopierten Zellbereich im Tabellenblatt "Gesamtzyklus" nach unten hin verlaufend eingefügt werden. Also nicht überschreiben, sondern nach unten aneinanderreihen.
Ich hoffe mit diesem Beispiel wird das ganze etwas klarer.
Vielen Dank schon mal bei der Hilfe.

Option Explicit Public Sub Betriebspunkte() Dim i As Long, z As Long, y As Long, loLetzteQ As Long Dim loLetzteZ As Long, wsZiel As Worksheet Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Set wsZiel = ThisWorkbook.Worksheets("Gesamtzyklus") With Worksheets("Betriebspunktdefinition") loLetzteQ = .Cells(.Rows.Count, 1).End(xlUp).Row - 3 End With With Worksheets("Zyklendefinition") For i = 2 To 101 y = 0 With .Columns(1) For z = 3 To 14 For y = 3 To loLetzteQ Step 5 If .Cells(z, i) = 1 Then With Worksheets("Betriebspunktdefinition") loLetzteZ = wsZiel.Cells(wsZiel.Rows.Count, 1) _ .End(xlUp).Offset(1).Row If wsZiel.Cells(1, 1) = "" Then loLetzteZ = 1 .Range(.Cells(y, 1), .Cells(y + 3, 7)).Copy _ wsZiel.Cells(loLetzteZ, 1) End With Else z = z + 1 End If Next y Next z End With Next i End With Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

With Worksheets("Betriebspunktdefiniton") loLetzteZ = wsZiel.Cells(wsZiel.Rows.Count, 1) _ .End(xlUp).Offset(1).Row If wsZiel.Cells(1, 1) = "" Then loLetzteZ = 1 .Range(.Cells(y, 1), .Cells(y + 3, 7)).Copy _ wsZiel.Cells(loLetzteZ, 1) z = z + 1 End With

Hallo Tobias,
dann müssten diese Zeilen angepasst werden:

loLetzteQ = .Cells(.Rows.Count, 1).End(xlUp).Row - 3
For y = 3 To loLetzteQ Step 5
.Range(.Cells(y, 1), .Cells(y + 3, 7)).Copy

Das würde ich dann so händeln, dass beim Makrostart abgefragt wird, wieviele Zeilen jeder Betriebspunkt hat.

Option Explicit
Public Sub Betriebspunkte()
Dim i As Long, z As Long, y As Long, loLetzteQ As Long
Dim loLetzteZ As Long, loAnzahl As Long, wsZiel As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
loAnzahl = Application.InputBox("Wieviele Zeilen hat jeder Betriebspunkt?", _
"Zeilenzahl pro Betriebspunkt", , , , , , 1) - 1
If loAnzahl > 0 Then
Set wsZiel = ThisWorkbook.Worksheets("Gesamtzyklus")
With Worksheets("Betriebspunktdefinition")
loLetzteQ = .Cells(.Rows.Count, 1).End(xlUp).Row - loAnzahl
End With
With Worksheets("Zyklendefinition")
For i = 2 To 101
y = 0
With .Columns(1)
For z = 3 To 14
For y = 3 To loLetzteQ Step loAnzahl + 2
If .Cells(z, i) = 1 Then
With Worksheets("Betriebspunktdefinition")
loLetzteZ = wsZiel.Cells(wsZiel.Rows.Count, 1) _
.End(xlUp).Offset(1).Row
If wsZiel.Cells(1, 1) = "" Then loLetzteZ = 1
.Range(.Cells(y, 1), .Cells(y + loAnzahl, 7)).Copy _
wsZiel.Cells(loLetzteZ, 1)
z = z + 1
End With
Else
z = z + 1
End If
Next y
Next z
End With
Next i
End With
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Aber eines ist hoffentlich klar. Das kann nur funktionieren, wenn alle Betriebspunkte die gleiche Anzahl an Zeilen haben.
Gruß Werner

Beliebteste Forumthreads (12 Monate)

Kopieren von Zellbereich mithilfe einer Beding.

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kopieren von Zellbereich mithilfe einer Beding.

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread