Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1408to1412
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Summenformeln nach Bedingungen per Makro einfügen

Summenformeln nach Bedingungen per Makro einfügen
19.02.2015 11:02:58
Dieter
Guten Morgen zusammen,
Nachdem mir gestern schon top geholfen wurde, bin ich direkt mit dem nächsten Anliegen bei euch.
Ich bräuchte dazu nämlich noch einen zweiten, etwas anderen Lösungsansatz.
Diverse verschachtelungen über Wenn-Funktionen wurden schon versucht - leider vergeblich.
Hierdrin wird erklärt, wovon ich rede:
https://www.herber.de/bbs/user/95870.xlsx
Wichtige Anmerkung: Werte UND Ergebnisse stehen beide in Spalte B und müssen drin bleiben!
Dies ist auch der Grund, warum eine ähnliche Funktion wie

=WENN(LINKS(A4;1)="X";SUMME(B4:INDEX(B:B;WENNFEHLER(ZEILE()+VERGLEICH($A5:$A$1048576;); 1048576)));  B4)  
nicht funktioniert. Ich habe keine Nebenstehende Spalte mit Werten mehr, sondern es sollen alle Daten und Ergebnisse bzw. Formeln in die gleiche Spalte.
Ich dachte im ersten Moment an eine VBA-Find-Offset-FormelEinfügen Kombination. Leider sind meine VBA Kenntnisse noch nicht so weitreichend.
Grüße,
Dieter

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Summenformeln nach Bedingungen per Makro einf
19.02.2015 11:17:01
Klaus
Hallo Dieter,
wenn ich dich korrekt verstehe, dann mit diesem Makro?
Es trägt die SUMME-Formel direkt in Spalte B ein.
Option Explicit
Sub SummeFormel()
Const fRow As Long = 2
Dim lRow As Long
Dim r As Range
Const xCol As Long = 1
Const wCol As Long = 2
Dim xfRow As Long
Dim xlRow As Long
With ActiveSheet
lRow = .Cells(.Rows.Count, xCol).End(xlUp).Row
For Each r In .Range(.Cells(fRow, xCol), .Cells(lRow, xCol))
If Left(r.Value, 1) = "X" Then
r.Select
xfRow = r.Row + 1
xlRow = lRow
On Error Resume Next
xlRow = WorksheetFunction.Match(r.Value, .Range(.Cells(r.Row + 1, xCol), .Cells( _
lRow, xCol)), False) + r.Row
On Error GoTo 0
Debug.Print xfRow & " " & xlRow
.Cells(r.Row, wCol).FormulaR1C1 = "=SUM(R" & xfRow & "C:R" & xlRow & "C)"
End If
Next r
End With
End Sub
Grüße
Klaus M.vdT.

Anzeige
AW: Summenformeln nach Bedingungen per Makro einf
19.02.2015 11:49:08
Dieter
Hallo,
Sieht schon mal definitiv nicht schlecht aus.
Jedoch muss ein X3 auch von einem X4 (oder X5 oder X5) gestoppt werden.
X4/X5/X6 Werte sollen nicht die darunter stehenden Werte, sondern die untergeordneten Ebenenwerte addieren, also wie im Beispiel bei Zeile B25: Addiert B28+B34.
Dies sind also 2 verschiedene Formeln - X3 Addiert ABC, X4 addiert X3.
https://www.herber.de/bbs/user/95872.xlsm
Alle Gelb markierten Felder müssen verformelt werden. Ist glaube ich nur eine kleine Abwandlung des Makros, die Logik hinter den Formeln ist halt ziemlich verwirrend, das kann ich verstehen.
MfG und schon mal vielen Dank,
Dieter

Anzeige
AW: Summenformeln nach Bedingungen per Makro einf
19.02.2015 12:28:48
Klaus
Jetzt habe ich mich festgebissen!!!!
In deinem Muster schreibst du, in Zeile 12 (X5) muss B13 und B21 addiert werden. X5 ab Zeile 12 hat aber erst Zeile 39 als Stopwert (der nächste X5 oder X6 oder höher). Darum meine ich, es muss B13, B21 und B35 addiert werden (da A35 auch einen X4-Wert hat).
Unter der Vorraussetzung das ich das richtig verstanden habe und du einen Fehler im Muster gemacht hast, könnte dieses Makro es lösen:
Option Explicit
Sub SummeFormel()
Const fRow As Long = 2
Dim lRow As Long
Dim r As Range
Dim r2 As Range
Dim xStop As Long
Const xCol As Long = 1
Const wCol As Long = 2
Dim xfRow As Long
Dim xlRow As Long
With ActiveSheet
lRow = .Cells(.Rows.Count, xCol).End(xlUp).Row
For Each r In .Range(.Cells(fRow, xCol), .Cells(lRow, xCol))
If Left(r.Value, 1) = "X" Then
xfRow = r.Row + 1
xStop = --WorksheetFunction.Substitute(r.Value, "X", "")
'Debug.Print xStop
xlRow = lRow
For Each r2 In .Range(.Cells(xfRow, xCol), .Cells(lRow, xCol))
On Error Resume Next
If Left(r2.Value, 1) = "X" Then
If --WorksheetFunction.Substitute(r2.Value, "X", "") >= xStop Then
xlRow = r2.Row
Exit For
End If
End If
On Error GoTo 0
Next r2
If Left(r.Offset(1, 0).Value, 1) = "X" Then
.Cells(r.Row, wCol).FormulaR1C1 = "=SUMIF(R" & xfRow & "C" & xCol & ":R" &  _
xlRow & "C" & xCol & ",""X" & xStop - 1 & """,R" & xfRow & "C:R" & xlRow & "C)"
Else
.Cells(r.Row, wCol).FormulaR1C1 = "=SUM(R" & xfRow & "C:R" & xlRow - 1 & "C)"
End If
End If
Next r
End With
End Sub
Falls nicht, bitte zum zwanzigsten Mal erklären :-)
LG,
Klaus M.vdT.

Anzeige
mini-Korrektur
19.02.2015 12:31:26
Klaus
Das erste Makro hat in B330 den Wert aus B342 unterschlagen. Korrigierte Version:
Option Explicit
Sub SummeFormel()
Const fRow As Long = 2
Dim lRow As Long
Dim r As Range
Dim r2 As Range
Dim xStop As Long
Const xCol As Long = 1
Const wCol As Long = 2
Dim xfRow As Long
Dim xlRow As Long
With ActiveSheet
lRow = .Cells(.Rows.Count, xCol).End(xlUp).Row
For Each r In .Range(.Cells(fRow, xCol), .Cells(lRow, xCol))
If Left(r.Value, 1) = "X" Then
xfRow = r.Row + 1
xStop = --WorksheetFunction.Substitute(r.Value, "X", "")
xlRow = lRow + 1
For Each r2 In .Range(.Cells(xfRow, xCol), .Cells(lRow, xCol))
On Error Resume Next
If Left(r2.Value, 1) = "X" Then
If --WorksheetFunction.Substitute(r2.Value, "X", "") >= xStop Then
xlRow = r2.Row
Exit For
End If
End If
On Error GoTo 0
Next r2
If Left(r.Offset(1, 0).Value, 1) = "X" Then
.Cells(r.Row, wCol).FormulaR1C1 = "=SUMIF(R" & xfRow & "C" & xCol & ":R" &  _
xlRow & "C" & xCol & ",""X" & xStop - 1 & """,R" & xfRow & "C:R" & xlRow & "C)"
Else
.Cells(r.Row, wCol).FormulaR1C1 = "=SUM(R" & xfRow & "C:R" & xlRow - 1 & "C)"
End If
End If
Next r
End With
End Sub
LG,
Klaus

Anzeige
zweite mini-Korrektur
19.02.2015 12:34:17
Klaus
Kein Funktionalitätsproblem, aber aus Prinzip: Das "Exit For" überspringt das "On Error Goto 0", dadurch bleibt die Fehlerbehandlung abgeschaltet und das soll nicht sein. Hättest du im Betrieb wahrscheinlich nicht mal gemerkt, aber ich kann nicht schlafen wenn so ein Fehler im Makro bleibt :-)
Option Explicit
Sub SummeFormel()
Const fRow As Long = 2
Dim lRow As Long
Dim r As Range
Dim r2 As Range
Dim xStop As Long
Const xCol As Long = 1
Const wCol As Long = 2
Dim xfRow As Long
Dim xlRow As Long
With ActiveSheet
lRow = .Cells(.Rows.Count, xCol).End(xlUp).Row
For Each r In .Range(.Cells(fRow, xCol), .Cells(lRow, xCol))
If Left(r.Value, 1) = "X" Then
xfRow = r.Row + 1
xStop = --WorksheetFunction.Substitute(r.Value, "X", "")
xlRow = lRow + 1
For Each r2 In .Range(.Cells(xfRow, xCol), .Cells(lRow, xCol))
On Error Resume Next
If Left(r2.Value, 1) = "X" Then
If --WorksheetFunction.Substitute(r2.Value, "X", "") >= xStop Then
xlRow = r2.Row
On Error GoTo 0
Exit For
End If
End If
On Error GoTo 0
Next r2
If Left(r.Offset(1, 0).Value, 1) = "X" Then
.Cells(r.Row, wCol).FormulaR1C1 = "=SUMIF(R" & xfRow & "C" & xCol & ":R" &  _
xlRow & "C" & xCol & ",""X" & xStop - 1 & """,R" & xfRow & "C:R" & xlRow & "C)"
Else
.Cells(r.Row, wCol).FormulaR1C1 = "=SUM(R" & xfRow & "C:R" & xlRow - 1 & "C)"
End If
End If
Next r
End With
End Sub
LG,
Klaus

Anzeige
AW: zweite mini-Korrektur
19.02.2015 12:43:52
Dieter
Hallo,
Das makro funktioniert ja perfekt!!! :)
Ein kleines anliegen noch - könntest du mir eventuell mit " 'hier kann man was ändern" oder ähnlichem markieren, wo ich die Zellen und Spaltenvariablen einsetze in der gesucht und addiert wird? Ich würde das auf mehrere Dokumente anwenden, in einem anderen z.B. wird in Spalte B der X6/X5 Wert gefunden und erst in Spalte D stehen die Werte :)
Vielen Dank!!
Mit freundlichen Grüßen,
Anton Huber

AW: zweite mini-Korrektur
19.02.2015 12:55:49
Klaus
Hallo Dieter-Anton,
freut mich dass ich die Logik eurer Musterdatei besser verstanden habe als ihr selber :-) *SCNR*
Um x-E in Spalte B zu suchen und Formeln in Spalte D auszugeben, einfach oben die Variablen ändern:
Const xCol As Long = 2
Const wCol As Long = 4

Wenn es dann nicht in Zeile 2, sondern erst in Zeile 17 losgeht, auch das ist Variabel:
Const fRow As Long = 17
und schon läuft das. Da ich aus Faulheit keine sprechenden Variablenbezeichnungen verwendet habe sondern kryptische Abkürzungen (ganz schlechter Stil!) gibt es als Ausgleich die komplett kommentierte Version des Makros:
Sub SummeFormel()
Const fRow As Long = 2      'in Zeile 2 geht es los, in Zeile 1 stehen Überschriften
Dim lRow As Long            'Variable um letzte Zeile zu ermitteln (muss ja nicht immer bis  _
1048576 laufen)
Dim r As Range              'wird einmal durchlaufen - alle Werte aus Spalte A (X und ABC)
Dim r2 As Range             'wird häufig durchlaufen: Bereich VON aktueller BIS letzter Zeile,  _
um mächtigere X-Stop Werte zu finden
Dim xStop As Long           'die mächtigkeit eines jeden X Wertes, um den Bereich zu stoppen
Const xCol As Long = 1      'X und ABC stehen in Spalte A = 1
Const wCol As Long = 2      'Werte (und später Formeln) stehen in Spalte B = 2
Dim xfRow As Long           'Formeln greifen AB dieser Zeile
Dim xlRow As Long           'Formeln greifen BIS zu dieser Zeile
With ActiveSheet
lRow = .Cells(.Rows.Count, xCol).End(xlUp).Row                                          ' _
letzte Zeile feststellen
For Each r In .Range(.Cells(fRow, xCol), .Cells(lRow, xCol))                            ' _
Alle Werte Zellenweise durchlaufen
If Left(r.Value, 1) = "X" Then                                                      ' _
Steht links ein X? Dann die Formel vorbereiten
xfRow = r.Row + 1                                                               ' _
eine Zeile unter der aktuellen startet die Formel
xStop = --WorksheetFunction.Substitute(r.Value, "X", "")                        'Mä _
chtigkeit vom aktuellen X feststellen
xlRow = lRow + 1                                                                'im  _
Zweifel geht die Formel bis zur letzten Zeile
For Each r2 In .Range(.Cells(xfRow, xCol), .Cells(lRow, xCol))                  ' _
Bereich AB aktueller Zeile +1 bis Ende durchlaufen
On Error Resume Next                                                        ' _
Fehlerbehandlung aus (dirty Trick)
If Left(r2.Value, 1) = "X" Then                                             ' _
steht links ein X?
If --WorksheetFunction.Substitute(r2.Value, "X", "") >= xStop Then         ' _
ist die Mächtigkeit des folgenden X genug, um das aktuelle X zu stoppen?
xlRow = r2.Row                                                          ' _
Falls ja, gehen die Formeln bis zu dieser Zeile
On Error GoTo 0                                                         ' _
Fehlerbehandlung wieder ein
Exit For                                                                ' _
und aus der r2 Schleife rausspringen, da die Zeile jetzt ermittelt wurde
End If
End If
On Error GoTo 0                                                             ' _
Fehlerbehandlung wieder ein
Next r2                                                                         ' _
dreckiger Trick: Wurde in der r2-Schleife nichts gefunden, gehts halt bis zur letzten Zeile (die
If Left(r.Offset(1, 0).Value, 1) = "X" Then                                     'je  _
nachdem diese oder jene Formel
.Cells(r.Row, wCol).FormulaR1C1 = "=SUMIF(R" & xfRow & "C" & xCol & ":R" &  _
xlRow & "C" & xCol & ",""X" & xStop - 1 & """,R" & xfRow & "C:R" & xlRow & "C)"
Else
.Cells(r.Row, wCol).FormulaR1C1 = "=SUM(R" & xfRow & "C:R" & xlRow - 1 & "C)"
End If
'die Formeln sind einfache R1C1-Versionen der Excelformeln, per STRING-Zerlegung  _
sind die Zeilennummern aus xlRow und xfRow reingestellt.
'sieht wüst aus, ist aber ganz einfach - Schau dir einfach die Formeln im  _
Excelblatt an :-)
End If
Next r
End With
End Sub
EDIT:
Grad in der Vorschau gesehen, das ist im Forencode kaum lesbar. Hab grad keine Code-Jeannie zur Hand. Naja, dann lade ich halt die Datei nochmal hoch:
https://www.herber.de/bbs/user/95875.xlsm
LG,
Klaus

Anzeige
AW: zweite mini-Korrektur
19.02.2015 13:18:57
Dieter
Perfekt, jetzt können wir wirklich super damit arbeiten.
Vielen lieben Dank dir!
Wünsche dir einen super Tag :)
MfG,
Dieter

Danke für die Rückmeldung!
19.02.2015 13:34:44
Klaus
Dieter,
Anton,
danke für die Rückmeldung, freut mich geholfen zu haben! Übrigens: Ich habe mir jetzt nochmal die Musterdatei vom Anfang des Thread angesehen - ich verstehe sie immer noch nicht :-) aber das macht ja jetzt auch nichts mehr.
Grüße,
Klaus M.vdT.

315 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige