|
Hallo zusammen,
Mit folgender Programmierung wird anhand eines Datums eine "1" in die Spalte gesetzt mit dem passenden Monat. Anhand eines Intervalls,werden weitere "1" gesetzt.
beispiel: ich habe das Datum 07.06.2024 und ein Intervall von 3 also wird in die Spalte Juni eine 1 gesetzt, in September und Dezember.
bis hierhin funktioniert auch alles. Nun möchte ich aber das in den Intervallen weiter "1"gesetzt werden, bis Dezember 2026 und da hapert es. Meine Programmierung endet mit Dezember 2024. kann hier wer helfen?
Sub setIntervall(rng As Range)
Dim dtDatum As Date
Dim interv As Integer, lastcol As Integer, i As Integer
Dim res As Variant
Dim strMonth As String
interv = rng.Value ' Anzahl der Monate, in die das Jahr aufgeteilt werden soll
lastcol = Cells(9, Columns.Count).End(xlToLeft).Column
If interv > 0 Then
dtDatum = rng.Offset(0, 1).Value
For i = 1 To 12
If Month(dtDatum) = i Then
strMonth = MonthName(i) & " " & Year(dtDatum)
res = Application.Match(strMonth, Rows("9:9"), 0)
If IsNumeric(res) Then
Dim j As Integer
For j = i To 12 Step interv ' Beginne im aktuellen Monat und wiederhole das Intervall über das Jahr
strMonth = MonthName(j) & " " & Year(dtDatum)
res = Application.Match(strMonth, Rows("9:9"), 0)
If IsNumeric(res) Then
Cells(rng.Row, res).Value = 1
End If
Next j
End If
Exit For
End If
Next i
Else
Cells(rng.Row, 21).Resize(1, lastcol - 3).ClearContents
End If
Application.EnableEvents = True
End Sub
interv = rng.Value ' Anzahl der Monate, in die das Jahr aufgeteilt werden soll
lastcol = Cells(9, Columns.Count).End(xlToLeft).Column
If interv > 0 Then
dtDatum = rng.Offset(0, 1).Value
For i = 1 To 12
If Month(dtDatum) = i Then
strMonth = MonthName(i) & " " & Year(dtDatum)
res = Application.Match(strMonth, Rows("9:9"), 0)
If IsNumeric(res) Then
Dim j As Integer
For j = i To 12 Step interv ' Beginne im aktuellen Monat und wiederhole das Intervall über das Jahr
strMonth = MonthName(j) & " " & Year(dtDatum)
res = Application.Match(strMonth, Rows("9:9"), 0)
If IsNumeric(res) Then
Cells(rng.Row, res).Value = 1
End If
Next j
End If
Exit For
End If
Next i
Else
Cells(rng.Row, 21).Resize(1, lastcol - 3).ClearContents
End If
Application.EnableEvents = True
End Sub
|