Excelpositionen von bis datum auf mehrere Zeilen verteilen mit Summen pro Monat (12)

gelöstFrage VB for Applications Entwicklung

Hallo Zusammen

Meine Problemstellung ist die folgende:
1 Vertrag hat mehrere Positionen
Die Positionen haben einen Merkmale von datum - bis datum mit Betrag
Ich muss nun die eine Position auf die Jahre verteilen und im Jahr den Betrag auf die Monate.
In der Bildbeilage ein Beispiel.

Die Verteilung von Zeitreihen mit Formeln pro Zeile kriegen ich hin, aber hierfür benötige ich VBA Code, da komme ich leider nicht mehr mit.
Die Erzeugung kann immer von Scratch beginnen - also im Zielblatt alles löschen und neu aufbauen.

vielen Dank für Eure Tipps
reto

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 391312

Url: https://administrator.de/forum/excelpositionen-von-bis-datum-auf-mehrere-zeilen-verteilen-mit-summen-pro-monat-12-391312.html

Ausgedruckt am: 24.05.2025 um 19:05 Uhr

5 Kommentare

Neuester Kommentar

Salü reto,
ein Gerüst für dich zum Anpassen:
https://we.tl/t-nS81EGzdbr

Sali l.

Salut Lummel
vielen, vielen dank - top

lg reto

Salut Lummel

Ich habe nun den Code noch so erweitet, dass die Monate auch gleich im Coding verwendet werden.

Ich hätte noch folgende Frage:
-ich müsste noch das Jahr in die Array Zeile schreiben - hast Du hier eine Idee, wie das am einfachsten ginge?
(Array habe ich erweitert - auch die Position für das Schreiben gefunden - aber das aktuelle Datum haben wir nicht direkt im Zugriff?)

lg u merci
reto

Sub DoSomeWork()
Dim months As Integer

Set wsSource = Sheets(1)
Set wsTarget = Sheets(2)
With wsSource
wsTarget.UsedRange.Clear
.Range("A1:H1").Copy wsTarget.Range("A1")
wsTarget.Range("H1:U1").Value = Array("year", "amount/m", "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12")

wsTarget.Range("A1").EntireRow.Font.Bold = True
For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
years = DateDiff("yyyy", cell.Offset(0, 3).Value, cell.Offset(0, 4).Value, vbMonday, vbFirstFourDays) + 1
months = DateDiff("m", cell.Offset(0, 3).Value, cell.Offset(0, 4).Value, vbMonday, vbFirstFourDays) + 1
For y = 1 To years
' next free row
Set rngDest = wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
' copy existing row to target
cell.EntireRow.Copy rngDest
' set amount per month
rngDest.Offset(0, 8).Value = cell.Offset(0, 2).Value / months
'schreibe noch das Jahr der Zeile

' determine first, last or complete year
If y = 1 Then
' first year
mStart = month(cell.Offset(0, 3).Value)
rngDest.Offset(0, 9 + mStart - 1).Resize(1, 12 - mStart + 1).Value = rngDest.Offset(0, 8).Value
ElseIf y = years Then
'last year
mEnd = month(cell.Offset(0, 4).Value)
rngDest.Offset(0, 9).Resize(1, mEnd).Value = rngDest.Offset(0, 8).Value
Else
'complete year
rngDest.Offset(0, 9).Resize(1, 12).Value = rngDest.Offset(0, 8).Value
End If
Next
Next
End With
wsTarget.Select
End Sub

rngDest.Offset(0, 8).Value

schreibst du dann dein Jahr.
und dann musst du natürlich alle nachfolgenden Offsets weiter nach hinten verschieben,also dass für den Amount/m in den Offset 9

rngDest.Offset(0, 9).Value

schreiben. und die Monatsdaten den Spalten-Offset auf 10 setzen, feedich.
Und natürlich die ANzahl Zellen für das Array korrigieren

wsTarget.Range("H1:V1").............

Sub DoSomeWork()
    Set wsSource = Sheets(1)
    Set wsTarget = Sheets(2)
    With wsSource
        wsTarget.UsedRange.Clear
        .Range("A1:H1").Copy wsTarget.Range("A1")  
        wsTarget.Range("I1:V1").Value = Array("year", "amount/m", "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12")  
        
        wsTarget.Range("A1").EntireRow.Font.Bold = True  
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            years = DateDiff("yyyy", cell.Offset(0, 3).Value, cell.Offset(0, 4).Value, vbMonday, vbFirstFourDays) + 1  
            months = DateDiff("m", cell.Offset(0, 3).Value, cell.Offset(0, 4).Value, vbMonday, vbFirstFourDays) + 1  
            
            For y = 1 To years
                ' next free row  
                Set rngDest = wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
                ' copy existing row to target  
                cell.EntireRow.Copy rngDest
                'set year  
                rngDest.Offset(0, 8).Value = Year(cell.Offset(0, 3).Value) + y - 1
                ' set amount per month  
                rngDest.Offset(0, 9).Value = cell.Offset(0, 2).Value / months
                ' determine first, last or complete year  
                If y = 1 Then
                    ' first year  
                    mStart = Month(cell.Offset(0, 3).Value)
                    rngDest.Offset(0, 10 + mStart - 1).Resize(1, 12 - mStart + 1).Value = rngDest.Offset(0, 9).Value
                ElseIf y = years Then
                    'last year  
                    mEnd = Month(cell.Offset(0, 4).Value)
                    rngDest.Offset(0, 10).Resize(1, mEnd).Value = rngDest.Offset(0, 9).Value
                Else
                    'complete year  
                    rngDest.Offset(0, 10).Resize(1, 12).Value = rngDest.Offset(0, 9).Value
                End If
            Next
        Next
    End With
    wsTarget.Select
End Sub