Wochentage+ Monatsenden einfügen
06.12.2021 13:43:03
Ugur
In der angefügten Datei:
https://www.herber.de/bbs/user/149616.xlsm
sollen die Werte mit einer ähnlichen, älteren Datei miteinander verglichen werden. Das Problem ist, dass zwischen dem alten und neuen Abzug das Datum unterschiedlich sein kann. Daher brauche ich ein Makro, das Zeilen in die Datei einfügt, in denen folgende Daten stehen sollen:
die kommenden zwei Wochen vom aktuellen Tag. Alle Freitage innerhalb der nächsten drei Monate inklusive der Monatsenden.
In diese Leeren Zeilen sollen dann die Werte übernommen werden, die sich in der vorherigen Zeile befinden.
Meine Vorgängerin hatte bereits eines begonnen, dies funktioniert bei mir jedoch irgendwie nicht, daher kann ich auch nicht wirklich sagen, ob das so funktioniert wie gewünscht oder ein völlig neuer Ansatz vonnöten ist.
Sub Zeileneinfügen_2()
' Makro1 Makro
Dim lastrow As Integer
Dim Wochentag
Dim Wochentag2
Dim Datum As Date
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Zeile = 2 To lastrow
For x = 1 To 10
Wochentag = Weekday(Cells(Zeile, 33))
Datum = Cells(Zeile, 33).Value
' If Wochentag 6 Then
If Cells(Zeile + 1, 33).Value - Cells(Zeile, 33).Value > 1 And Cells(Zeile, 34).Value - Cells(Zeile + 1, 34).Value 0 Then 'wenn Abstand zwischen zwei Daten mehr als 1 Tage
Rows(Zeile + 1).Insert
Cells(Zeile + 1, 33) = "=WORKDAY(R[-1]C,5,2)" 'Wochentag einfügen -> immer den Freitag + letzten Tag im Monat
Range(Cells(Zeile, 1), Cells(Zeile, 24)).Select 'A-X kopieren & einfügen
Selection.Copy
Cells(Zeile + 1, 1).PasteSpecial
Application.CutCopyMode = False
Cells(Zeile, 34).Select 'AH kopieren & einfügen
Selection.Copy
Cells(Zeile + 1, 34) = "0"
Application.CutCopyMode = False
Cells(Zeile, 35).Select 'AI kopieren & einfügen
Selection.Copy
Cells(Zeile + 1, 35).PasteSpecial
Application.CutCopyMode = False
Cells(Zeile, 36).Select 'AJ kopieren & einfügen
Selection.Copy
Cells(Zeile + 1, 36) = "0"
Range(Cells(Zeile, 37), Cells(Zeile, 45)).Select 'AK-AS kopieren & einfügen
Selection.Copy
Cells(Zeile + 1, 37).PasteSpecial
Application.CutCopyMode = False
End If
Zeile = Zeile + 1
'Wenn 10 Zeilen pro Sachnummer eingefügt, dann nächste Sachnummer suchen und erst ab dieser wieder Zeilen einfügen
If x = 10 Then
Do
Zeile = Zeile + 1
If Cells(Zeile, 1) Cells(Zeile - 1, 1) Then
Exit Do
End If
Loop
Zeile = Zeile - 1
OpenForms = DoEvents
End If
Next x
Next Zeile
'Call Abrufe
'Call offene_Menge
End Sub
ich hoffe ich konnte es einigermaßen verständlich erklären und danke im voraus :)