AW: Keys in Dictionary
23.05.2017 19:22:33
Daniel
Hi
das Problem düfte entstehen, wenn du die Keys in die Zellen zurückschreibst.
Es sind Texte, aber Excel versucht einen Text in ein Datum zu verwandeln, wenn es der Meinung ist, dass der Text wie ein Datum aussieht.
Da du das ganze per VBA machst, wendet Excel die amerikanischen Regeln an, um ein Datum zu erkennen.
Du verwendest jedoch die deutsche Schreibweise, in der manche Monatsschreibweisen gleich dem Amerikanischen sind und machen nicht. Daher bleibt manchmal der Text erhalten und manchmal wird in ein Datum gewandelt.
Im Prinzip hast du zwei möglichkeiten:
a) deine Keys sollen weiterhin Texte bleiben.
Dann musst du bei der Key-Generierung das Texterkennungszeichen ' voranstellen, damit die Umwandlung in ein Datum auf jeden Fall unterbleibt
b) deine Keys sollen richtige Datumswerte werden. Hierzu generierst du den Key als Datumswert und nimmst den ersten des jeweiligen Monats.
Da die Keys dann echte Datumswerte sind und auch so in die Zellen geschrieben werden, kannst du die gewünschte Schreibweise über das Zahlenformat der Zellen einstellen.
Code für Variante a)
hierzu einfach in dieser Zeile das Hochkomma ergeänzen:
sDatum = "'" & Choose(iMonat, ..."
Code für Variante b)
hier dann der vollständige Code.
als Zahlenformat für die Spalte kannst du dann "MMM JJ" einstellen.
Public Sub Monatswerte_addieren()
Dim MyDict As Object
Dim vTemp As Variant
Dim lZeile As Long
Dim iJahr As Long
Dim iMonat As Long
Dim sDatum As Date
Set MyDict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Spalte 1 bis 21") ' den Tabellenblattnamen ggf. anpassen!
vTemp = .Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For lZeile = LBound(vTemp, 1) To UBound(vTemp, 1)
If vTemp(lZeile, 1) "" And IsDate(vTemp(lZeile, 1)) Then
sDatum = CDate(Format(vTemp(lZeile, 1), "YYYY-MM-01"))
MyDict(sDatum) = MyDict(sDatum) + CDbl(vTemp(lZeile, 2))
End If
Next lZeile
.Range("H2:I" & .Cells(.Rows.Count, 8).End(xlUp).Row).ClearContents
.Range("H2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
.Range("I2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.items)
End With
Application.ScreenUpdating = True
Set MyDict = Nothing
End Sub
Gruß Daniel