AW: Datum und Summe anzeigen
22.06.2018 10:33:48
UweD
Hallo
Dann hast du im Eingabeblatt nur die Überschrift und sonst kein Daten stehen.
hier mit Warnung.
Option Explicit
Sub Auflisten2()
Dim Eingabe, Neu, LR As Double, Pfad As String, DatNam As String
Application.ScreenUpdating = False 'Bildschirmflackern ausschalten
Set Eingabe = Sheets("Eingabe")
Set Neu = Sheets.Add(After:=Sheets(Sheets.Count))
Pfad = "X:\Temp\" 'Oder
'Pfad = ThisWorkbook.Path & "\"
LR = Eingabe.Cells(Eingabe.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
If LR = 1 Then MsgBox "Keine Daten vorhanden": Exit Sub
With Neu
'Spalten in neue Tabelle kopieren
Eingabe.Columns(1).Resize(, 3).Copy .Columns(1)
'Formeln setzen und in Werte umwandeln
.Cells(1, 5) = "Monat"
.Cells(1, 6) = "Summe"
.Cells(2, 5).Resize(LR - 1, 1).FormulaR1C1 = "=DATE(YEAR(RC[-2]),MONTH(RC[-2]),1)" ' auf Monat/Jahr reduzieren
.Cells(2, 6).Resize(LR - 1, 1).FormulaR1C1 = "=SUMIFS(C[-4],C[-5],RC[-5],C[-1],RC[-1])"
.UsedRange.Value = .UsedRange.Value
'Duplikate löschen
.Columns(1).Resize(, 6).RemoveDuplicates Columns:=Array(1, 5), Header:=xlYes
'überflüssige Spalten löschen und formatieren
.Columns(2).Resize(, 3).Delete xlLeft
.Columns(2).NumberFormat = "mmm yyyy"
'Sortieren
With .Sort
.SortFields.Add Key:=Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending
.SortFields.Add Key:=Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending
.SetRange Columns(1).Resize(, 3)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'verschieben in Neue Datei
.Move
End With
'speichern und schließen
DatNam = Pfad & Format(Date, "YYYYMMDD")
ActiveWorkbook.SaveAs Filename:=DatNam, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
MsgBox "Fertig! Datei '" & DatNam & "' erstellt"
End Sub
Noch was.
hier noch ein cdate drum.
If Cells(Target.Row, 3) = "" Then Cells(Target.Row, 3) = CDate(Format(Date, "DD.MM.YYYY")) _
LG UweD