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