VBA - Werte hochsummieren | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Makro in einem allgemeinen Modul 'Ermittelt auf Basis hierachisch strukturierter Daten Teilergebnisse Sub prcTeilergebnisse() Dim wks As Worksheet Dim lngZeile As Long Dim arrZeileL_Stufe(1 To 4) As Long Dim StatusCalc As Long Dim intStufe As Integer, intJ As Integer Dim strText As String Set wks = ActiveSheet 'Makrobremsen lösen With Application .ScreenUpdating = False .EnableEvents = False StatusCalc = .Calculation .Calculation = xlCalculationManual End With With wks lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile für Teilergebnis-Formelbereich bei allen Stufen setzen For intJ = 1 To 4 arrZeileL_Stufe(intJ) = lngZeile Next For lngZeile = lngZeile To 3 Step -1 'Stufe ermiteln auf Basis der Anzahl Punkte im Text in Spalte A strText = Trim(.Cells(lngZeile, 1).Text) If strText = "" Then intStufe = 0 Else intStufe = Len(strText) - Len(VBA.Replace(strText, ".", "")) + 1 End If 'Stufe auswerten Select Case intStufe Case 0 'Leerzeile(n) zwischen Projekten 'Letzte Zeile für Teilergebnis-Formelbereich bei allen Stufen setzen For intJ = 1 To 4 arrZeileL_Stufe(intJ) = lngZeile - 1 Next Case 1 To 3 'Projekt, Teilprojekt, AP 'TEILERGEBNIS-Formel einfügen .Cells(lngZeile, 3).FormulaR1C1 = _ "=SUBTOTAL(9,R[1]C:R[" & arrZeileL_Stufe(intStufe) - lngZeile & "]C)" 'Letzte Zeile für Teilergebnis-Formelbereich neu setzen For intJ = intStufe To 4 arrZeileL_Stufe(intJ) = lngZeile - 1 Next Case 4 'Task End Select Next 'Formeln durch Werte ersetzen lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row With .Range(.Cells(3, 3), .Cells(lngZeile, 3)) .Calculate '.Value = .Value End With End With 'Makrobremsen zurücksetzen With Application .ScreenUpdating = True .EnableEvents = True .Calculation = StatusCalc End With End Sub

Hallo Dip,
hier inkl. Formeln/Werte für die Monate.
Die Formeln werden jetzt durch die Werte ersetzt, da hatte ich vergessen, eine Kommentartzeile wieder zu aktivieren.
Gruß
Franz

'Makro in einem allgemeinen Modul
'Ermittelt auf Basis hierachisch strukturierter Daten Teilergebnisse
Sub prcTeilergebnisse()
Dim wks As Worksheet
Dim lngZeile As Long, lngSpalte As Long
Dim arrZeileL_Stufe(1 To 4) As Long
Dim StatusCalc As Long
Dim intStufe As Integer, intJ As Integer
Dim strText As String
Set wks = ActiveSheet
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wks
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Letzte Zeile für Teilergebnis-Formelbereich bei allen Stufen setzen
For intJ = 1 To 4
arrZeileL_Stufe(intJ) = lngZeile
Next
For lngZeile = lngZeile To 3 Step -1
'Stufe ermiteln auf Basis der Anzahl Punkte im Text in Spalte A
strText = Trim(.Cells(lngZeile, 1).Text)
If strText = "" Then
intStufe = 0
Else
intStufe = Len(strText) - Len(VBA.Replace(strText, ".", "")) + 1
End If
'Stufe auswerten
Select Case intStufe
Case 0 'Leerzeile(n) zwischen Projekten
'Letzte Zeile für Teilergebnis-Formelbereich bei allen Stufen setzen
For intJ = 1 To 4
arrZeileL_Stufe(intJ) = lngZeile - 1
Next
Case 1 To 3 'Projekt, Teilprojekt, AP
'TEILERGEBNIS-Formel einfügen
.Cells(lngZeile, 3).FormulaR1C1 = _
"=SUBTOTAL(9,R[1]C:R[" & arrZeileL_Stufe(intStufe) - lngZeile & "]C)"
'Letzte Zeile für Teilergebnis-Formelbereich neu setzen
For intJ = intStufe To 4
arrZeileL_Stufe(intJ) = lngZeile - 1
Next
Case 4 'Task
End Select
Next
'Formeln für Monate kopieren
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngZeile = 3 To lngZeile
If InStr(1, .Cells(lngZeile, 3).FormulaR1C1, "=SUBTOTAL(") > 0 Then
For lngSpalte = 5 To .Cells(2, .Columns.Count).End(xlToLeft).Column Step 13
.Cells(lngZeile, 3).Copy
With .Range(.Cells(lngZeile, lngSpalte), .Cells(lngZeile, lngSpalte + 11))
.PasteSpecial Paste:=xlPasteFormulas
.Calculate
.Value = .Value 'Formeln durch Werte ersetzen
End With
Next
End If
Next
'Formeln durch Werte ersetzen in Spalte C
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(3, 3), .Cells(lngZeile, 3))
.Calculate
.Value = .Value
End With
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub

Option Explicit Sub AdditionenVBA() Dim lngZ As Long, lngC As Long, arQ, ZW() As Double Dim zz As Long, ST As Long, cc As Long lngZ = Cells(Rows.Count, 1).End(xlUp).Row - 2 lngC = Cells(2, Columns.Count).End(xlToLeft).Column arQ = Cells(3, 1).Resize(lngZ, lngC) ReDim ZW(1 To 3, 3 To lngC) ' Zwischenwerte Stufen 1-3, Spalten ab C For zz = lngZ To 1 Step -1 If arQ(zz, 1) "" Then ST = Len(arQ(zz, 1)) - Len(Replace(arQ(zz, 1), ".", "")) + 1 Select Case ST Case 1 ZW_Ausgabe ZW, zz, 1 Case 2 To 3 For cc = 3 To lngC If cc Mod 13 4 Then _ ZW(ST - 1, cc) = ZW(ST - 1, cc) + ZW(ST, cc) Next cc ZW_Ausgabe ZW, zz, ST Case 4 For cc = 3 To lngC If cc Mod 13 4 Then _ ZW(ST - 1, cc) = ZW(ST - 1, cc) + arQ(zz, cc) Next cc Case Else: Stop End Select End If Next zz End Sub Sub ZW_Ausgabe(WW, z As Long, tt As Long) Dim dd As Long, cc As Long, w12(0, 1 To 12) As Double Cells(z + 2, 3) = WW(tt, 3) ' Total WW(tt, 3) = 0 For dd = 0 To Fix(UBound(WW, 2) / 13) - 1 ' x Jahre For cc = 1 To 12 ' je 12 Monate w12(0, cc) = WW(tt, 13 * dd + 4 + cc) WW(tt, 13 * dd + 4 + cc) = 0 Next cc Cells(z + 2, 5 + 13 * dd).Resize(, 12) = w12 ' für 1 Jahr Next dd End Sub

Sub AdditionenVBAProjekt(ByVal Zeile1 As Long, ByVal Zeile2 As Long) Dim lngZ As Long, lngC As Long, arQ, ZW() As Double Dim zz As Long, ST As Long, cc As Long, StatusCalc As Long Const AnzSt As Long = 4 ' Anzahl Stufen With ActiveSheet lngZ = Zeile2 - Zeile1 + 1 lngC = .Cells(2, Columns.Count).End(xlToLeft).Column arQ = Cells(Zeile1, 1).Resize(lngZ, lngC) End With ReDim ZW(1 To AnzSt - 1, 3 To lngC) ' Zwischenwerte pro Stufe, Spalten ab C With Application ' Makrobremsen lösen .ScreenUpdating = False .EnableEvents = False StatusCalc = .Calculation .Calculation = xlCalculationManual End With For zz = lngZ To 1 Step -1 If arQ(zz, 1) "" Then ST = Len(arQ(zz, 1)) - Len(Replace(arQ(zz, 1), ".", "")) + 1 Select Case ST Case 1 ZW_Ausgabe ZW, zz, 1, Zeile1 Case 2 To AnzSt - 1 For cc = 3 To lngC If cc Mod 13 4 Then _ ZW(ST - 1, cc) = ZW(ST - 1, cc) + ZW(ST, cc) Next cc ZW_Ausgabe ZW, zz, ST, Zeile1 Case AnzSt For cc = 3 To lngC If cc Mod 13 4 Then _ ZW(ST - 1, cc) = ZW(ST - 1, cc) + arQ(zz, cc) Next cc Case Else: Stop End Select End If Next zz 'Makrobremsen zurücksetzen With Application .ScreenUpdating = True .EnableEvents = True .Calculation = StatusCalc End With End Sub

Hallo Allerseits!
Entschuldigt meine späte Antwort, ich war die letzten beiden Tagen auf ein Seminar, deshalb abwesend...
@Franz/Erich: Mit der Festlegung von Konstanten hast Du den Code noch eleganter und benutzerfreundlicher optimiert, herzlichen Dank dafür! Damit kann ich nun grosse Projektplanungen über eine sehr lange Periode schnell und peformanceoptimiert durchführen. Einen grossen Dank an Dir und Erich für die wertvolle Hilfe! Die Lösung ist besser als ich mir erhofft habe :-)
Gerne würde ich an dieser Stelle eine ergänzende Problemstellung basierend auf das Planungsfile einbringen (siehe Datei im Anhang, Blatt csv).
https://www.herber.de/bbs/user/87528.xlsx
Es geht darum, die WBS Elemente in Spalte A, Blatt "Version VBA" in die Spalte A, Blatt "csv" zu kopieren (ohne Duplikate!), und zwar nur die entsprechende ausgewählte Stufe(mit dem Filter würde ich die gewünschte Stufe wählen).
Im Blatt "csv", Zelle B2 würde ich das entsprechende Planungsjahr auswählen.
Die Monate auf Zeile 4 würden sich entsprechend anpassen (Funktion Monatsende()).
In der Zelle D5 würde ich die Lösung mittels der Funktion Summenprodukt lösen. Wie Ihr aber erkennt, kann Excel aufgrund von mangelnder Ressourcen bzw. grosser Datenrange/-kalkulation den Wert nicht berechnen. Wäre die Umsetzung der Funktion Summenprodukt in VBA möglich?
Nachfolgend meine bescheidende Lösungmöglichkeit,

Sub test_sumproduct()
Worksheets("csv").Range("D5:O10").FormulaR1C1 = _
Evaluate("=SUMPRODUCT((R[-1]C=Version_VBA!R3C6:R3C303)*(RC[-3]=Version_VBA!C1)*(Version_VBA! _
C6:C303))")
End Sub

leider erhalte ich in der Zelle die Fehlermeldung #WERT!...
Über irgendwelche Tipps/Hilfe würde ich mich sehr freuen!
Beste Grüsse
Dip
Ps. @ Erich: Wie sagt man so schön, das Banale braucht man nicht zu schälen...Ist wichtig dass man sich manchmal zurück besinnt, an das was man eingentlich tut und ob dies auch sinnvoll ist :-)

Beliebteste Forumthreads (12 Monate)

VBA - Werte hochsummieren

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread