VBA: Zellen verschieben nach neuer KW

Sub Makro1() ' Makro1 Makro ' Planung nach Druck kopieren Range("B5:C25").Select Selection.Copy Sheets("Druck").Select ActiveWindow.SmallScroll Down:=-25 Range("A7:B27").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Planung").Select Range("D5:E25").Select Application.CutCopyMode = False Selection.Copy Sheets("Druck").Select Range("C7:D27").Select ActiveSheet.Paste End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro1() ' Makro1 Makro ' Planung nach Druck kopieren Range("B5:E25").Copy Sheets("Druck").Range("A7:D27").PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, _ SkipBlanks:=False, _ Transpose:=False Application.CutCopyMode = False End Sub

Sub Makro2() ' Makro2 ' Planung nach Druck kopieren Dim i As Long Dim iOffset As Integer Dim kw1 As Integer, kw2 As Integer For i = 1 To Range("B5:E25").Rows.Count iOffset = iOffset + 1 If i > 1 Then kw1 = Application.WeekNum(Range("B" & (i + 4)).Value,21) kw2 = Application.WeekNum(Range("B" & (i + 4)).offset(-1).Value,21) If kw1 > kw2 Then iOffset = iOffset + IIf(kw1 > kw2, 1, 0) End If Worksheets("Druck").Range("A" & (6 + iOffset)).Resize(, 4).Value = Range("B" & (4 + i)).Resize(, 4).Value Next End Sub

Sub Makro2() ' Makro2 ' Planung nach Druck kopieren Dim i As Long Dim iOffset As Integer Dim kw1 As Integer, kw2 As Integer For i = 1 To Range("B5:E25").Rows.Count If Range("B" & (i + 4)) "" Then 'ist zelle nicht leer If Month(Range("B" & (i + 4)).Value) = Range("B3").Value Then 'vergleich ob gleicher monat iOffset = iOffset + 1 If i > 1 Then kw1 = Application.WeekNum(CDate(Range("B" & (i + 4)).Value), 21) kw2 = Application.WeekNum(CDate(Range("B" & (i + 4)).Offset(-1).Value), 21) If kw1 > kw2 Then iOffset = iOffset + IIf(kw1 > kw2, 1, 0) End If Worksheets("Druck").Range("A" & (6 + iOffset)).Resize(, 4).Value = Range("B" & (4 + i)).Resize(, 4).Value End If End If Next End Sub


Sub Makro2()
' Makro2
' Planung nach Druck kopieren
Dim i      As Long
Dim iOffset As Integer
Dim kw1    As Integer, kw2 As Integer
Dim iZeilenbasis As Integer
Dim arrBereiche(1 To 2)                       'die Zahl nach "to" an die Anzahl der Bereiche anpassen
arrBereiche(1) = "B5:E25,6"                   'Bereiche entsprechend der Notation unten dran schreiben.
arrBereiche(2) = "B29:E49,32"                 ' 6 bzw 32 sind eine Zeilennr unter dem Einfügebereich
For cnt = 1 To UBound(arrBereiche)            'schleife über die Bereiche
iZeilenbasis = Range(Split(arrBereiche(cnt), ",")(0)).Row - 1
iOffset = 0
For i = 1 To Range(Split(arrBereiche(cnt), ",")(0)).Rows.Count 'schleife über jede Zeile des Quell-Bereiches
'Da die 4 + i in Summe die Zeilennummer ergeben, ist bei Startzelle B5 eine 4 zu setzen
If Range("B" & (i + iZeilenbasis))  "" Then 'ist Zelle (Schleifenzähler i + iZeilenbasis = 5 nicht leer
If Month(Range("B" & (i + iZeilenbasis)).Value) = Range("B" & (iZeilenbasis - 1)).Value Then 'vergleich ob gleicher monat
iOffset = iOffset + 1
If i > 1 Then
kw1 = Application.WeekNum(CDate(Range("B" & (i + iZeilenbasis)).Value), 21)
kw2 = Application.WeekNum(CDate(Range("B" & (i + iZeilenbasis)).Offset(-1).Value), 21)
If kw1 > kw2 Then iOffset = iOffset + IIf(kw1 > kw2, 1, 0)
End If
'arrBereiche(cnt)  ist z.b."B5:E25,6"
'Split(arrBereiche(cnt), ",")(1)
'durch split wird daruas Feld(0) = B5:E25  und Feld(1) = 6
'ergibt Range("A" & (Split(arrBereiche(cnt), ",")(1) + iOffset)) also z.b. A7
'Resize vergrößert den Zielbereich (Resize(Zeilenanzahl,Spaltenanzahl)
' mit Range(A7").Resize(,4) wird daraus der Bereich "A7:E7"
Worksheets("Druck").Range("A" & (Split(arrBereiche(cnt), ",")(1) + iOffset)).Resize(, 4).Value = Range("B" & (i + iZeilenbasis)).Resize(, 4).Value
End If
End If
Next
Next
End Sub

Sub druckLöschen() ' druckLöschen Makro Sheets("Druck").Select Range("A7:D27").Select ActiveWindow.SmallScroll Down:=20 Range("A7:D27,A33:D53").Select Range("A33").Activate Selection.ClearContents ActiveWindow.SmallScroll Down:=-20 End Sub

Sub Test() Dim Z As Long Dim S As Long Dim Ende As Long '--- Kopieren Sheets("Planung").Range("B5:C25").Copy Sheets("Druck").Range("A7") Sheets("Planung").Range("D5:E25").Copy Sheets("Druck").Range("C7") '--- Leerzeilen einfügen With Sheets("Druck") For S = 1 To 3 Step 2 'Schleife über beide Bereiche Ende = 27 For Z = Ende To 7 + 1 Step -1 If WorksheetFunction.WeekNum(.Cells(Z, S), 21) _ WorksheetFunction.WeekNum(.Cells(Z - 1, S), 21) Then .Range(.Cells(Z, S), .Cells(Ende, S + 1)).Copy .Cells(Z + 1, S) .Cells(Z, S).Resize(, 2).Clear Ende = Ende + 1 End If Next Next End With End Sub

Hallo Daniel, danke für die Meldung.
1. Das Einfügen von B5:C25 im Arbeitsblatt "Druck" unter A7:B27 erfolgte bei meinem aufgezeichneten Vorgang mit "nur Werte einfügen", da die Zellen B5:C25 per Formel befüllt sind. Mit deinem Code erhalte ich im Ziel-Arbeitsblatt nur #BEZUG!
Ich nehme an, mein Code hat das hier geregelt:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
2. Das mit den leeren Zeilen nach jeder Woche funktioniert leider nicht. Nach Ausführen des Makros erscheint die Meldung:
Laufzeitfehler `1004`:
Die WeekNum-Eigenschaft des WorksheetFunction-Objektes kann nicht zugeordnet werden.
Wenn ich auf "Debuggen" klicke, werden im VBA diese 2 Zeilen gelb markiert:
If WorksheetFunction.WeekNum(.Cells(Z, S), 21) _
WorksheetFunction.WeekNum(.Cells(Z - 1, S), 21) Then
Die Datumsangaben habe ich ohne Kalenderwochenfunktion erstellt, falls das wichtig zu wissen ist...

Sub Test() Dim Z As Long Dim S As Long Dim Ende As Long '--- Kopieren Sheets("Planung").Range("B5:C25").Copy Sheets("Druck").Range("A7").PasteSpecial Paste:=xlPasteValues Sheets("Planung").Range("D5:E25").Copy Sheets("Druck").Range("C7").PasteSpecial Paste:=xlPasteValues '--- Leerzeilen einfügen With Sheets("Druck") For S = 1 To 3 Step 2 'Schleife über beide Bereiche Ende = 27 For Z = Ende To 7 + 1 Step -1 If WorksheetFunction.WeekNum(CDate(Left(.Cells(Z, S), 8)), 21) _ WorksheetFunction.WeekNum(CDate(Left(.Cells(Z - 1, S), 8)), 21) Then .Range(.Cells(Z, S), .Cells(Ende, S + 1)).Copy .Cells(Z + 1, S) .Cells(Z, S).Resize(, 2).Clear Ende = Ende + 1 End If Next Next End With End Sub

Sub Makro1() Dim Z As Long Dim LetzteWoche As Integer Dim aktWoche As Integer '--- Als Wert übertragen Sheets("Planung").Range("B5:C25").Copy Sheets("Druck").Range("A7").PasteSpecial Paste:=xlPasteValues Sheets("Planung").Range("B29:C49").Copy Sheets("Druck").Range("A33").PasteSpecial Paste:=xlPasteValues '--- Leerzeilen einfügen On Error Resume Next With Sheets("Druck") LetzteWoche = 0 LetzteWoche = WorksheetFunction.WeekNum(CDate(.Cells(53, 1)), 21) For Z = 52 To 7 Step -1 aktWoche = 0 aktWoche = WorksheetFunction.WeekNum(CDate(.Cells(Z, 1)), 21) If LetzteWoche 0 And aktWoche 0 Then .Range(.Cells(Z, S), .Cells(Ende, S + 1)).Copy .Cells(Z + 1, S) .Cells(Z, S).Resize(1, 2).Clear End If LetzteWoche = aktWoche Next End With End Sub

Beliebteste Forumthreads (12 Monate)

VBA: Zellen verschieben nach neuer KW

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread