roenson
Goto Top

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

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
datumsverteilung mehrere zeilen

Content-Key: 391312

Url: https://administrator.de/contentid/391312

Ausgedruckt am: 29.03.2024 um 06:03 Uhr

Mitglied: 137443
Lösung 137443 31.10.2018 aktualisiert um 12:14:48 Uhr
Goto Top
Salü reto,
ein Gerüst für dich zum Anpassen:
https://we.tl/t-nS81EGzdbr

Sali l.
Mitglied: roenson
roenson 01.11.2018 um 08:13:16 Uhr
Goto Top
Salut Lummel
vielen, vielen dank - top

lg reto
Mitglied: roenson
roenson 01.11.2018 um 10:46:32 Uhr
Goto Top
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
Mitglied: 137443
Lösung 137443 01.11.2018 aktualisiert um 11:15:16 Uhr
Goto Top
In
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
Mitglied: roenson
roenson 01.11.2018 um 12:09:29 Uhr
Goto Top
top! vielen Dank