und noch mal mit VBA
01.04.2010 11:28:56
Erich
Hi Tom,
"Ich wollte das auch gern mit einem Macro lösen, um flexibler zu sein."
hättest du besser schon bei deiner ersten Anfrage geschrieben. So etwas kann man nicht so einfach raten...
Hier eine weitere Lösung mit VBA:
Option Explicit
Public Sub test_Dictionary()
Dim intJab As Integer, myDic, arrV, intJbis As Integer, aStrK() As String
Dim zz As Long, arrK, dblJS() As Double, lngZ As Long, jj As Integer, datM As Date
intJab = 2008 ' 1. Ergebnis-Jahr vorgeben
Set myDic = CreateObject("Scripting.Dictionary")
' --------------------------------------------------------------------- Einlesen
With Sheets("Rohdaten")
arrV = .Range("D2:J" & .Cells(.Rows.Count, 10).End(xlUp).Row)
intJbis = Year(Application.Max(.Columns(10))) ' letztes Jahr
End With
ReDim aStrK(1 To UBound(arrV)) As String
' --------------------------------------------------------------------- Zählen
For zz = 1 To UBound(arrV)
aStrK(zz) = Format(arrV(zz, 2), "dd.mm.yyyy") & _
Format(arrV(zz, 7), "dd.mm.yyyy") & arrV(zz, 1) ' Key
If myDic.Exists(aStrK(zz)) Then
myDic(aStrK(zz)) = myDic(aStrK(zz)) + 1 ' hochzählen
Else
myDic.Add aStrK(zz), 1 ' neu anlegen
End If
Next
' --------------------------------------------------------------------- Addieren
arrK = myDic.Keys
ReDim dblJS(1 To myDic.Count, intJab To intJbis)
For lngZ = 1 To UBound(arrV)
zz = Application.Match(aStrK(lngZ), arrK, 0)
jj = Year(arrV(lngZ, 2))
If jj >= intJab Then _
dblJS(zz, jj) = dblJS(zz, jj) + arrV(lngZ, 3) ' 1. Rate
datM = DateSerial(jj, Month(arrV(lngZ, 2)) + 1, 1)
While datM = intJab Then _
dblJS(zz, jj) = dblJS(zz, jj) + arrV(lngZ, 4) ' lfd. Rate
datM = DateSerial(Year(datM), Month(datM) + 1, 1)
Wend
jj = Year(arrV(lngZ, 7))
If jj >= intJab Then _
dblJS(zz, jj) = dblJS(zz, jj) + arrV(lngZ, 6) ' letzte Rate
Next lngZ
' --------------------------------------------------------------------- Ausgeben
ReDim arrV(1 To myDic.Count, 1 To 4)
For zz = 1 To myDic.Count
arrV(zz, 1) = Mid(arrK(zz - 1), 21)
arrV(zz, 2) = CDate(Left(arrK(zz - 1), 10))
arrV(zz, 3) = CDate(Right(Left(arrK(zz - 1), 20), 10))
arrV(zz, 4) = myDic(arrK(zz - 1))
Next zz
With Sheets("Ergebnis").Cells(3, 2) ' hier Ausgabe ab B3, das Blatt muss es geben
.Resize(, 4) = Split("Fahrzeug-" & vbLf & "typ Leasing-" & vbLf & _
"beginn Leasing-" & vbLf & "ende Anzahl")
For jj = 0 To intJbis - intJab ' Jahre für Spaltenkopf
.Offset(, 4 + jj) = "Raten " & intJab + jj
Next jj
.Offset(1).Resize(myDic.Count, 4) = arrV
.Offset(1, 4).Resize(myDic.Count, intJbis - intJab + 1) = dblJS
.EntireRow.HorizontalAlignment = xlHAlignCenter
.EntireRow.VerticalAlignment = xlVAlignCenter
.Resize(, 5 + intJbis - intJab).EntireColumn.AutoFit
End With
End Sub
Und hier die Bei-Spiel-Mappe: https://www.herber.de/bbs/user/68912.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort