Option Explicit
'<<< A N P A S S E N >>>
'Blattbeschreibung
'ZeilenNummern
Private Const cQ_Z_UEBERSCHRIFT = 1
Private Const cQ_Z_ERSTEWERTEZEILE = 2
'Spaltennummern
Private Const cQ_SP_DATUM = 1
Private Const cQ_SP_NAME = 2
Private Const cQ_SP_ANZAHL = 3
Private Const cQ_SP_SUMME = 4
'<<< A N P A S S E N E N D E >>>
'Blattbeschreibung Auswertungsdatei
Private Const cZ_BLTNAME_GESAMT = Gesamtauswertung
Private Const cZ_Z_UEBERSCHRIFT = 1
Private Const cZ_Z_ERSTEWERTEZEILE = 2
Private Const cZ_SP_DATUM = 1
Private Const cZ_SP_JAHRMONAT = 2
Private Const cZ_SP_NAME = 3
Private Const cZ_SP_ANZAHL = 4
Private Const cZ_SP_SUMME = 5
Sub AuswertungMonatNameSummeAnzahlSummeSumme()
'*** Auswertung des aktiven Blattes nach
'*** Monat,Name, Summe Anzahl, Summe Summe
'***
'*** Die Auswertung wird in eine neue Datei geschrieben
'*** Pro Monat wird ein Blatt angelegt
'*** Die Auswertung wird im Pfad der aktiven Mappe abgelegt
'*** Name: Dateiname_Auswertungyyyymmddhhnnss.xls
Dim wb As Workbook, ws As Worksheet, wbz As Workbook, wsz As Worksheet
Dim x As Long
->aktive Mappe, aktives Blatt setzen
Set wb = ActiveWorkbook
Set ws = ActiveSheet
->Auswertedatei anlegen
Set wbz = Workbooks.Add
->überflüssige Blätter löschen
Application.DisplayAlerts = False
For x = wbz.Worksheets.Count To 2 Step -1: wbz.Worksheets(x).Delete: Next
Application.DisplayAlerts = True
Set wsz = wbz.Worksheets(1)
wsz.Name = cZ_BLTNAME_GESAMT
wbz.SaveAs FileName:=wb.Path & Application.PathSeparator & _
Left(wb.Name, Len(wb.Name) - 4) & _
_Auswertung & Format(Now(), yyyymmddhhnnss) & .xls
->auszuwertende Daten auf cZIEL_BLTNAME_GESAMT übertragen
Call AuszuwertendeDatenAufZielblattUebertragen(ws, wsz)
->auszuwertende Daten verdichten
If Not AuszuwertendeDatenVerdichten(wsz) Then GoTo AUFRAEUMEN
->Monatsblätter erzeugen
Call MonatsblaetterErzeugen(wbz, wsz)
->Gesamtauswertung löschen
If wbz.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
wbz.Worksheets(cZ_BLTNAME_GESAMT).Delete
Application.DisplayAlerts = True
End If
wbz.Save->Zieldatei speichern
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing: Set wbz = Nothing: Set wsz = Nothing
End Sub
'******************************************************************************
Private Function AuszuwertendeDatenAufZielblattUebertragen(ws As Worksheet, _
wsz As Worksheet)
Dim l_letzteZeileQ As Long, x As Long
->Splaten formatieren, Überschriften übertragen
wsz.Columns(cQ_SP_DATUM).NumberFormat = yyyy-mm-dd
With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_DATUM)
.NumberFormat = @: .Font.Bold = True
.Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_DATUM).Value
End With
wsz.Columns(cQ_SP_DATUM).NumberFormat = @
With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_NAME)
.NumberFormat = @: .Font.Bold = True
.Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_NAME).Value
End With
wsz.Columns(cQ_SP_DATUM).NumberFormat = @
->eigene Spalte für Jahr/Monat
With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_JAHRMONAT)
.NumberFormat = @: .Font.Bold = True
.Value = Jahr/Monat
End With
wsz.Columns(cZ_SP_JAHRMONAT).NumberFormat = @
With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_ANZAHL)
.NumberFormat = @: .Font.Bold = True
.Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_ANZAHL).Value
End With
With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_SUMME)
.NumberFormat = @: .Font.Bold = True
.Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_SUMME).Value
End With
->letzte Zeile aus Quellblatt feststellen
l_letzteZeileQ = ws.Cells(ws.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
->Werte vom Quellblatt auf Zielblatt kopieren
ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_DATUM), _
ws.Cells(l_letzteZeileQ, cQ_SP_DATUM)).Copy
wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM).Select
Selection.PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
wsz.Columns(cQ_SP_DATUM).NumberFormat = yyyy-mm-dd
wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_DATUM).NumberFormat = @
ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_NAME), _
ws.Cells(l_letzteZeileQ, cQ_SP_NAME)).Copy
wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME).Select
wsz.Paste
ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_ANZAHL), _
ws.Cells(l_letzteZeileQ, cQ_SP_ANZAHL)).Copy
wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_ANZAHL).Select
wsz.Paste
ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_SUMME), _
ws.Cells(l_letzteZeileQ, cQ_SP_SUMME)).Copy
wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_SUMME).Select
wsz.Paste
->Grid setzen
With wsz.UsedRange
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
For x = 7 To 12
With .Borders(x):
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next
End With
wsz.Cells(1, 1).Select
End Function
'******************************************************************************
Private Function AuszuwertendeDatenVerdichten(wsz As Worksheet) As Boolean
Dim lRows As Long, x As Long
Dim dDate1 As Date, dDate2 As Date
->letzte Zeile aus Quellblatt feststellen
lRows = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
->Spalte Datum prüfen
For x = cZ_Z_ERSTEWERTEZEILE To lRows
If Not IsDate(wsz.Cells(x, cZ_SP_DATUM).Value) Then
MsgBox _
Datum in Zeile & x & ist ungültig. & vbLf & _
Bitte korrigieren und Makro erneut starten.
GoTo AUFRAEUMEN
End If
Next
->Nach Name, Datum sortieren
wsz.Range(wsz.Cells(cZ_Z_ERSTEWERTEZEILE, 1), _
wsz.Cells(lRows, wsz.UsedRange.Columns.Count)).Sort _
Key1:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME), Order1:=xlAscending, _
Key2:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM), Order2:=xlAscending, _
Header:=xlNo
For x = lRows To cZ_Z_ERSTEWERTEZEILE + 1 Step -1
->Zeile und vorhergehende Zeile
->gleicher Name ?
If wsz.Cells(x, cZ_SP_NAME).Value = wsz.Cells(x - 1, cZ_SP_NAME).Value Then
->Pruefen ob gleicher Monat
dDate1 = wsz.Cells(x, cZ_SP_DATUM).Value
dDate2 = wsz.Cells(x - 1, cZ_SP_DATUM).Value
If (Year(dDate1) = Year(dDate2)) And _
(Month(dDate1) = Month(dDate2)) Then
->Monat/Jahr gleich -> ANZAHL, SUMME verdichten
wsz.Cells(x - 1, cZ_SP_ANZAHL).Value = _
wsz.Cells(x - 1, cZ_SP_ANZAHL).Value + wsz.Cells(x, cZ_SP_ANZAHL).Value
wsz.Cells(x - 1, cZ_SP_SUMME).Value = _
wsz.Cells(x - 1, cZ_SP_SUMME).Value + wsz.Cells(x, cZ_SP_SUMME).Value
wsz.Rows(x).Delete
End If
End If
Next
->letzte Zeile aus Quellblatt feststellen
lRows = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
->Spalte Jahr/Monat ausfüllen, Spalte Datum auf den 1. des Monats setzen
For x = cZ_Z_ERSTEWERTEZEILE To lRows
dDate1 = wsz.Cells(x, cZ_SP_DATUM).Value
wsz.Cells(x, cZ_SP_JAHRMONAT).Value = Year(dDate1) & & Format(dDate1, mmm)
dDate1 = 1. & Month(dDate1) & . & Year(dDate1)
wsz.Cells(x, cZ_SP_DATUM).Value = dDate1
Next
->Nach Datum,Name sortieren
wsz.Range(wsz.Cells(cZ_Z_ERSTEWERTEZEILE, 1), _
wsz.Cells(lRows, wsz.UsedRange.Columns.Count)).Sort _
Key1:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM), Order1:=xlAscending, _
Key2:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME), Order2:=xlAscending, _
Header:=xlNo
AuszuwertendeDatenVerdichten = True
AUFRAEUMEN:
End Function
'******************************************************************************
Private Function MonatsblaetterErzeugen(wbz As Workbook, wsz As Worksheet)
Dim ws As Worksheet, Zelle As Range
Dim sJahrMonat As String, lRowEnd As Long, lRowAnf As Long, x As Long
Do
->letzte Zeile aus Quellblatt feststellen
lRowEnd = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
->alles abgearbeitet ?
If lRowEnd <= cZ_Z_ERSTEWERTEZEILE Then Exit Do
sJahrMonat = wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT).Value
->Anfang des Monats suchen
If lRowEnd = cZ_Z_ERSTEWERTEZEILE Then
lRowAnf = lRowEnd->nur eine Zeile übrig
Else
Set Zelle = wsz.Range( _
wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_JAHRMONAT), _
wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT)).Find( _
What:=sJahrMonat, _
After:=wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
lRowAnf = Zelle.Row
End If
->Gesamtauswertung-Blatt an den Anfang der Mappe kopieren
wsz.Copy Before:=wbz.Worksheets(1)
Set ws = ActiveSheet
->Blattnamen setzen Jahr/Monat
ws.Name = sJahrMonat
->Zeilen, die nicht zu diesem Monat gehören, löschen
If lRowAnf > cZ_Z_ERSTEWERTEZEILE Then
ws.Rows(cZ_Z_ERSTEWERTEZEILE & : & (lRowAnf - 1)).Delete
End If
->Spalte JahrMonat und Spalte Datum löschen
ws.Columns(cZ_SP_JAHRMONAT).Delete
ws.Columns(cZ_SP_DATUM).Delete
->in der Gesamtauswetung Monatszeilen löschen (abgearbeitet)
wsz.Rows(lRowAnf & : & lRowEnd).Delete
Loop
AUFRAEUMEN:
Set ws = Nothing: Set Zelle = Nothing
End Function
