Datumswerte aus Spalten aufsummieren
11.02.2019 10:33:50
Philipp
@Admin: Bitte verschieben wenn notwendig
Hi, & sorry dass ich den Thread liegen gelassen habe. Mich hat jedoch der Ehrgeiz gepackt und ich wollte mich etwas tiefer einarbeiten.
@Hajo: Sorry2! Hätte früher ein File hochladen sollen.
Ich bin mittlerweile so weit gekommen, dass das VBA Skript mir eine Spalte sauber auswertet. ICh schaffe es jedoch nicht das Skript so an zu passen, dass es über die weiteren Zeilen drüber iteriert und mir auch diese Daten ausliest. Auch wenn er ziemlich zusammengestückelt ist und bestimmt noch optimiert werden kann.
Anbei die Testdaten:
Kurze Anmerkung: Was in den ersten Spalten steht ist irrelevant. Wichtig sind nur die Spalten
G:N die ausgewertet werden müssen.
https://www.herber.de/bbs/user/127561.xlsm
Anbei der Code:
Sub Datenaufbereitung()
Dim i As Long, j As Long
Dim lpMaxLine As Long
Dim lpCount As Long
Dim lpNumber As Long
Dim lpWord As String
Dim WS As Worksheet
Dim lArray() As String
Dim bFound As Boolean
Dim mySheetName As String
Dim mySheetName2 As String
Set WS = ThisWorkbook.Worksheets("Testdaten")
lpMaxLine = WS.Range("A:Z").SpecialCells(xlCellTypeLastCell).Row
For i = 2 To lpMaxLine
lpWord = WS.Cells(i, 8)
bFound = False
For j = 1 To lpCount
If lArray(1, j) = lpWord Then
lArray(2, j) = lArray(2, j) + 1
bFound = True
End If
Next j
If Not bFound Then
lpCount = lpCount + 1
ReDim Preserve lArray(1 To 3, 1 To lpCount)
lArray(1, lpCount) = lpWord
lArray(2, lpCount) = 1
End If
Next i
' neues Worksheet nach Datum und wechsel in den jeweiligen Statusbericht:
mySheetName = "Statusbericht" & " - " & VBA.Date
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(mySheetName).Delete
Err.Clear
Application.DisplayAlerts = True
Worksheets.Add.Name = "Statusbericht" & " - " & VBA.Date
Set WS = ThisWorkbook.Worksheets("Statusbericht" & " - " & VBA.Date)
' Aufsummieren der Ergebnisse und als Datum ausgeben:
For i = 1 To lpCount
WS.Cells(i + 1, 1) = CDate(lArray(1, i))
WS.Cells(i + 1, 2) = lArray(2, i)
Next i
' leere Zellen löschen:
For i = 1 To lpCount
If WS.Cells(i + 1, 1) = "" Then
' WS.Rows(i + 1).Delete Shift:=xlUp
WS.Range(WS.Cells(i + 1, 1), WS.Cells(i + 1, 3)).Delete Shift:=xlUp
End If
Next i
' sortieren nach Datum:
Columns("A:C").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Addieren der Werte in Zeile 3:
For i = 1 To lpCount
WS.Cells(2, 3) = WS.Cells(2, 2)
WS.Cells(i, 3) = WS.Cells(i - 1, 3) + WS.Cells(i, 2)
Next i
' Überschiften Tabelle:
Cells(1, 1) = Sheets("Testdaten").Range("G1").Value & vbCrLf & "Datum"
Cells(1, 2) = Sheets("Testdaten").Range("G1").Value & vbCrLf & "Summe"
Cells(1, 3) = Sheets("Testdaten").Range("G1").Value & vbCrLf & "Summe Over all"
Cells(1, 4) = Sheets("Testdaten").Range("H1").Value & vbCrLf & "Datum"
Cells(1, 5) = Sheets("Testdaten").Range("H1").Value & vbCrLf & "Summe"
Cells(1, 6) = Sheets("Testdaten").Range("H1").Value & vbCrLf & "Summe Over all"
Cells(1, 7) = Sheets("Testdaten").Range("I1").Value & vbCrLf & "Datum"
Cells(1, 8) = Sheets("Testdaten").Range("I1").Value & vbCrLf & "Summe"
Cells(1, 9) = Sheets("Testdaten").Range("I1").Value & vbCrLf & "Summe Over all"
Cells(1, 10) = Sheets("Testdaten").Range("J1").Value & vbCrLf & "Datum"
Cells(1, 11) = Sheets("Testdaten").Range("J1").Value & vbCrLf & "Summe"
Cells(1, 12) = Sheets("Testdaten").Range("J1").Value & vbCrLf & "Summe Over all"
Cells(1, 13) = Sheets("Testdaten").Range("K1").Value & vbCrLf & "Datum"
Cells(1, 14) = Sheets("Testdaten").Range("K1").Value & vbCrLf & "Summe"
Cells(1, 15) = Sheets("Testdaten").Range("K1").Value & vbCrLf & "Summe Over all"
Cells(1, 16) = Sheets("Testdaten").Range("L1").Value & vbCrLf & "Datum"
Cells(1, 17) = Sheets("Testdaten").Range("L1").Value & vbCrLf & "Summe"
Cells(1, 18) = Sheets("Testdaten").Range("L1").Value & vbCrLf & "Summe Over all"
Cells(1, 19) = Sheets("Testdaten").Range("M1").Value & vbCrLf & "Datum"
Cells(1, 20) = Sheets("Testdaten").Range("M1").Value & vbCrLf & "Summe"
Cells(1, 21) = Sheets("Testdaten").Range("M1").Value & vbCrLf & "Summe Over all"
Cells(1, 22) = Sheets("Testdaten").Range("N1").Value & vbCrLf & "Datum"
Cells(1, 23) = Sheets("Testdaten").Range("N1").Value & vbCrLf & "Summe"
Cells(1, 24) = Sheets("Testdaten").Range("N1").Value & vbCrLf & "Summe Over all"
' Autofit Column
Columns("A:Z").EntireColumn.AutoFit
End Sub