Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.07.2024 18:36:17
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Monatsdaten wieder auseinander nehmen

Monatsdaten wieder auseinander nehmen
01.11.2012 21:36:25
Mexsalem
Hallo,
robert konnte mir netterweise bei dieser Frage helfen:
https://www.herber.de/forum/archiv/1280to1284/t1282308.htm#1282308
Er konnte ein Makro erstellen, dass mir einen Zahlungsstrom anhand des Datums zusammenfassen kann. Es sieht so aus (Beispielmappe siehe o.g. Link):
Option Explicit
Sub tt()
Dim dstart As Date, estart As Date
Dim myrate As Long, datez As Long
Dim rngz As Long, x As Long, i As Long, zz As Long, nz As Long, endrate As Long
x = 2
zz = 2
rngz = 1
nz = 2
Application.ScreenUpdating = False
Range("E2:H1000").ClearContents
For i = nz To Cells(Rows.Count, 1).End(xlUp).Row
myrate = Cells(i, 3)
dstart = Cells(nz, 1)
If Cells(i + 1, 3) = Cells(i, 3) Then
endrate = endrate + myrate
rngz = rngz + 1
Else
Cells(zz, 5) = dstart
Cells(zz, 6) = Cells(i, 2)
Cells(zz, 7) = Cells(i, 3)
Cells(zz, 8) = rngz
zz = zz + 1
nz = i + 1
rngz = 1
End If
Next i
x = Cells(Rows.Count, 5).End(xlUp).Row
Cells(x + 2, 5) = Cells(2, 5)
Cells(x + 2, 6) = Cells(x, 6)
Cells(x + 2, 8) = Application.Sum(Range(Cells(2, 8), Cells(x, 8)))
Application.ScreenUpdating = True
End Sub
Nun möchte ich auch gerne den umgekehrten Weg, d.h. ich gebe eine Zusammenfassung vor und ein Makro soll mir den Zahlungsstrom erstellen. Die Laufzeiten varieren, d.h. die Zusammenfassung ist unterschiedlich lang (mal eine Zeile "von bis", mal x Zeilen).
Ausgangslage/Eingabe:
   von	            bis 	  Rate	      Anzahl Monate
01.12.2012	31.12.2012	 100,00   	1
01.01.2013	30.04.2013	 200,00   	4
01.05.2013	30.09.2013	 500,00   	5
01.10.2013	28.02.2014	 5.000,00   	5
01.03.2014	31.10.2014	 2.500,00   	8


Gewünschtes Ergebnis :
   von	           bis	          Rate
01.12.2012	31.12.2012	 100,00
01.01.2013	31.01.2013	 200,00
01.02.2013	28.02.2013	 200,00
01.03.2013	31.03.2013	 200,00
01.04.2013	30.04.2013	 200,00
01.05.2013	31.05.2013	 500,00
01.06.2013	30.06.2013	 500,00
01.07.2013	31.07.2013	 500,00
01.08.2013	31.08.2013	 500,00
01.09.2013	30.09.2013	 500,00
01.10.2013	31.10.2013	 5.000,00
01.11.2013	30.11.2013	 5.000,00
01.12.2013	31.12.2013	 5.000,00
01.01.2014	31.01.2014	 5.000,00
01.02.2014	28.02.2014	 5.000,00
01.03.2014	31.03.2014	 2.500,00
01.04.2014	30.04.2014	 2.500,00
01.05.2014	31.05.2014	 2.500,00
01.06.2014	30.06.2014	 2.500,00
01.07.2014	31.07.2014	 2.500,00
01.08.2014	31.08.2014	 2.500,00
01.09.2014	30.09.2014	 2.500,00
01.10.2014	31.10.2014	 2.500,00
Wie baue ich das Makro von robert um, damit es das kann ?
Grüße
Mexsalem

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 07:43:12
Tino
Hallo,
habe zwar den Code von robert nicht verwendet, aber vielleicht gehts mit diesem ja auch.
Ich gehe mal davon aus das die Daten auf der Tabelle1 ab A2 vorliegen,
sonst muss dies angepasst werden.
Die Ausgabe erfolgt auch auf Tabelle1 ab E1, muss evtl. auch angepasst werden.
Sub ListeGross()
Dim ArrData, ArrAus()
Dim n&, nn&, intDif%
Dim DateAnfang As Date, DateEnde As Date
Dim curRate As Currency

With Tabelle1 'Tabelle anpassen 
    With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
        ArrData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
    End With
End With
Redim Preserve ArrAus(1 To 3, 1 To 1)
For n = 1 To Ubound(ArrData)
    DateAnfang = ArrData(n, 1)
    DateEnde = ArrData(n, 2)
    curRate = ArrData(n, 3)
    intDif = DateDiff("m", DateAnfang, DateEnde) + 1
    Redim Preserve ArrAus(1 To 3, 1 To Ubound(ArrAus, 2) + intDif)
    Do While DateAnfang < DateEnde
        nn = nn + 1
        ArrAus(1, nn) = DateAnfang
        ArrAus(2, nn) = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 0)
        ArrAus(3, nn) = curRate
        DateAnfang = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 1)
    Loop
Next n
Call ArrayTranspose(ArrAus)

'Ausgabe ***************************** 
With Tabelle1 'Tabelle anpassen 
    'Überschrift 
    With .Range("E1").Resize(, 3)
        .Cells(1, 1) = "von"
        .Cells(1, 2) = "bis"
        .Cells(1, 3) = "Rate"
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    'Daten 
    With .Range("E2").Resize(nn, 3)
        .Columns(1).Resize(, 2).NumberFormat = "dd.mm.yyyy"
        .Columns(3).NumberFormat = "#,##0.00"
        .Value = ArrAus
        .EntireColumn.AutoFit
    End With
End With
End Sub

Sub ArrayTranspose(varArray)
Dim NewArr(), n&, nn&
Redim Preserve NewArr(1 To Ubound(varArray, 2), 1 To Ubound(varArray))
For n = 1 To Ubound(varArray, 2)
    For nn = 1 To Ubound(varArray)
        NewArr(n, nn) = varArray(nn, n)
    Next nn
Next n
varArray = NewArr
End Sub
Gruß Tino

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 08:42:31
UweD
Hallo
hier ein Vorschlag von mir.
Sub Splitten_Datum()
On Error GoTo Fehler
Dim TB, i%, j%, Mon%, Von As Date
Dim Rate%, Neu As Date, LR&
Set TB = ActiveSheet
LR = TB.Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
Application.ScreenUpdating = False
For i = LR To 2 Step -1
Von = TB.Cells(i, 1)
Mon = TB.Cells(i, 4) - 1
Rate = TB.Cells(i, 3)
If Mon > 1 Then
For j = Mon To 1 Step -1
TB.Rows(i + 1).Insert xlDown
Neu = DateSerial(Year(Von), Month(Von) + j, 1)
TB.Cells(i + 1, 1) = Neu
TB.Cells(i + 1, 2) = DateSerial(Year(Neu), Month(Neu) + 1, 0)
TB.Cells(i + 1, 3) = Rate
If j = 1 Then
TB.Cells(i, 2) = DateSerial(Year(Von), Month(Von) + 1, 0)
End If
Next j
End If
Next i
TB.Columns(4).ClearContents
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Gruß UweD

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 21:43:11
Mexsalem
Hallo Tino, Hallo UweD,
zuerst einmal ein Danke für die Zeit, die Ihr heute morgen gleich in die Makros investiert habt. Der Code von Tino läuft bei mir leider auf folgende Fehlermeldung auf :
Laufzeitfehler 458 :
Variable verwendet einen in Visual Basis nicht unterstützten Automatisierungstyp
Der Fehler läßt sich bei dieser Zeile im Sub ArrayTranspose(varArray) auslösen :
varArray = NewArr
Ich vermute, dass hängt viellicht mit der EXCEL 97-Version zusammmen, die ich noch verwende. Die VBA-Hilfe findet das Schlüsselwort varArray nicht. Oder fehlt hier eine Referenzierung ? Wenn ich Sub ArrayTranspose(ByRef varArray() As Variant)
nehme kommt zumindest eine andere Fehlermeldung :-)
Fehler bei Kompilierung / Keine Zuweisung an Datenfeld möglich.
@Tino : kannst du bitte nochmal helfen ? Meine Daten stehen in Spalte A,B,C,D ab Zeile 2 (wegen Überschrift in Zeile 1) in Tabelle1.
Der Code von UweD funktioniert. Aber etwas überrascht war ich, das die ursprüngliche Zusammenfassung überschrieben und durch den Zahlungsstrom ersetzt wird. Hier muss ich mal schauen, ob ich es schaffe, den Code dahingehend zu ändern, dass er mir den Zahlungsstrom unter die Zusammenfassung stellt.
Liebe Grüße
Mexsalem

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 21:53:28
Tino
Hallo,
auf die Version habe ich nicht geachtet, kannst mal so versuchen.
Sub ListeGross()
Dim ArrData, ArrAus()
Dim n&, nn&, intDif%
Dim DateAnfang As Date, DateEnde As Date
Dim curRate As Currency

With Tabelle1 'Tabelle anpassen 
    ArrData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
Redim Preserve ArrAus(1 To 3, 1 To 1)
For n = 1 To Ubound(ArrData)
    DateAnfang = ArrData(n, 1)
    DateEnde = ArrData(n, 2)
    curRate = ArrData(n, 3)
    intDif = DateDiff("m", DateAnfang, DateEnde) + 1
    Redim Preserve ArrAus(1 To 3, 1 To Ubound(ArrAus, 2) + intDif)
    Do While DateAnfang < DateEnde
        nn = nn + 1
        ArrAus(1, nn) = DateAnfang
        ArrAus(2, nn) = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 0)
        ArrAus(3, nn) = curRate
        DateAnfang = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 1)
    Loop
Next n
Call ArrayTranspose(ArrAus)

'Ausgabe ***************************** 
With Tabelle1 'Tabelle anpassen 
    'Überschrift 
    With .Range("E1").Resize(, 3)
        .Cells(1, 1) = "von"
        .Cells(1, 2) = "bis"
        .Cells(1, 3) = "Rate"
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    'Daten 
    With .Range("E2").Resize(nn, 3)
        .Columns(1).Resize(, 2).NumberFormat = "dd.mm.yyyy"
        .Columns(3).NumberFormat = "#,##0.00"
        .Value = ArrAus
        .EntireColumn.AutoFit
    End With
End With
End Sub

Sub ArrayTranspose(varArray())
Dim NewArr(), n&, nn&
Redim Preserve NewArr(1 To Ubound(varArray, 2), 1 To Ubound(varArray))
For n = 1 To Ubound(varArray, 2)
    For nn = 1 To Ubound(varArray)
        NewArr(n, nn) = varArray(nn, n)
    Next nn
Next n
varArray = NewArr
End Sub
Gruß Tino

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 22:04:52
Mexsalem
Hallo Tino,
danke für die schnelle Antwort, aber die Änderung von
With Tabelle1 'Tabelle anpassen
With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
ArrData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
End With

auf
With Tabelle1 'Tabelle anpassen
ArrData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
brachte mir wieder diese Fehlermeldung :
Fehler bei Kompilierung / Keine Zuweisung an Datenfeld möglich.
Gruss
Mexsalem

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 22:12:41
Tino
Hallo,
habe keine 97er Version mehr, ist auch recht lange her wo ich diese verwendet habe.
Versuche es mal mit dieser.
Sub ListeGross()
Dim ArrData(), ArrAus()
Dim n&, nn&, intDif%
Dim DateAnfang As Date, DateEnde As Date
Dim curRate As Currency

With Tabelle1 'Tabelle anpassen 
    With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
        ArrData = .Value
        DateAnfang = Application.WorksheetFunction.Min(.Columns(1).Resize(, 2))
        DateEnde = Application.WorksheetFunction.Max(.Columns(1).Resize(, 2))
    End With
End With

Redim Preserve ArrAus(1 To DateDiff("m", DateAnfang, DateEnde) + 1, 1 To 3)
For n = 1 To Ubound(ArrData)
    DateAnfang = ArrData(n, 1)
    DateEnde = ArrData(n, 2)
    curRate = ArrData(n, 3)
    intDif = DateDiff("m", DateAnfang, DateEnde) + 1
    Do While DateAnfang < DateEnde
        nn = nn + 1
        ArrAus(nn, 1) = DateAnfang
        ArrAus(nn, 2) = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 0)
        ArrAus(nn, 3) = curRate
        DateAnfang = DateSerial(Year(DateAnfang), Month(DateAnfang) + 1, 1)
    Loop
Next n

'Ausgabe ***************************** 
With Tabelle1 'Tabelle anpassen 
    'Überschrift 
    With .Range("E1").Resize(, 3)
        .Cells(1, 1) = "von"
        .Cells(1, 2) = "bis"
        .Cells(1, 3) = "Rate"
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    'Daten 
    With .Range("E2").Resize(nn, 3)
        .Columns(1).Resize(, 2).NumberFormat = "dd.mm.yyyy"
        .Columns(3).NumberFormat = "#,##0.00"
        .Value = ArrAus
        .EntireColumn.AutoFit
    End With
End With
End Sub
Gruß Tino

Anzeige
AW: Monatsdaten wieder auseinander nehmen
02.11.2012 22:20:12
Mexsalem
Hallo Tino,
leider immer noch dieselbe Fehlermeldung, diesmal bei
ArrData = .Value
Gruss
Mexsalem

AW: Monatsdaten wieder auseinander nehmen
02.11.2012 22:31:15
Tino
Hallo,
habe noch mal was umgebaut, evtl. gehts ja so.
Lade auch mal meine Beispieldatei hoch, vielleicht habe wir nur andere Ausgangsdaten.
https://www.herber.de/bbs/user/82457.xls
Gruß Tino

AW: Monatsdaten wieder auseinander nehmen
02.11.2012 22:41:11
Mexsalem
Hallo Tino,
habe leider noch keinen Erfolg mit deiner Beispielmappe. Funktioniert bei dir sicher, bei mir jedoch kommt wieder diesselbe Fehlermeldung.
Hier ist meine Beispielmappe mit deinem letzten Makro. Es sind keine weiteren Mappen geöffnet, die stören könnten.
https://www.herber.de/bbs/user/82458.xls
Gruss
Mexsalem

Anzeige
kann nicht helfen...
02.11.2012 22:54:18
Tino
Hallo,
bei mir läuft es wie gewollt, Ergebnis sollte wie unten gezeigt aussehen.
Vielleicht kann mal einer drüber schauen der Version 97 noch auf seinem Rechner hat.
 ABCDEFG
1vonbis Rate  vonbisRate
201.12.1231.12.12      100,00    01.12.201231.12.2012100,00
301.01.1330.04.13      200,00    01.01.201331.01.2013200,00
401.05.1330.09.13      500,00    01.02.201328.02.2013200,00
501.10.1328.02.14   5.000,00    01.03.201331.03.2013200,00
601.03.1431.10.14   2.500,00    01.04.201330.04.2013200,00
7    01.05.201331.05.2013500,00
8    01.06.201330.06.2013500,00
9    01.07.201331.07.2013500,00
10    01.08.201331.08.2013500,00
11    01.09.201330.09.2013500,00
12    01.10.201331.10.20135.000,00
13    01.11.201330.11.20135.000,00
14    01.12.201331.12.20135.000,00
15    01.01.201431.01.20145.000,00
16    01.02.201428.02.20145.000,00
17    01.03.201431.03.20142.500,00
18    01.04.201430.04.20142.500,00
19    01.05.201431.05.20142.500,00
20    01.06.201430.06.20142.500,00
21    01.07.201431.07.20142.500,00
22    01.08.201431.08.20142.500,00
23    01.09.201430.09.20142.500,00
24    01.10.201431.10.20142.500,00
25       

Gruß Tino

Anzeige
AW: kann nicht helfen...
02.11.2012 23:10:00
Mexsalem
Hallo Tino,
danke für all deine Bemühungen, vielleicht kann jemand anderes aus dem Forum noch helfen.
Gute Nacht
Mexsalem

AW: kann nicht helfen...
02.11.2012 23:10:16
Mexsalem
Hallo Tino,
danke für all deine Bemühungen, vielleicht kann jemand anderes aus dem Forum noch helfen.
Gute Nacht
Mexsalem

AW: ein letzter Versuch...
04.11.2012 07:45:42
Mexsalem
Moin Tino,
Danke für deinen erneuten Versuch, aber die Fehlermeldung "Keine Zuweisung an Datenfeld" ist hartnäckig :-). Sie wird in der Zeile
ArrData = DatenTabelle.Range("A2", DatenTabelle.Cells(RowMax, 3))
ausgelöst. Da der Code von UweD funktioniert hat, werde ich versuchen, mir diesen an meine Arbeitsmappe anzupassen.
Gruß
Mexsalem
Anzeige

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige