AW: ...und was hast du davon? Oder ist das nur 'ne ...
05.10.2012 07:57:40
Lutz
Hallo Rudi, hallo Luc,
die Funktion sieht folgendermaßen aus:
Option Explicit
Public Function fncSUMME_EIS(Bereich As Range, rngEIS As Range, rngPhase As Range) As Double
'Spezielle Summierung von Daten basierend auf 2 Kriterien
'Bereich mit den zu summierenden Werten
'rngEIS = Zelle mit E, I oder S in Titelzeile der Summenspalte
'rngPhase = Zelle mit "Plan" oder "Vorschau" in Titelzeile der Summenspalten
Dim Spalte As Long, Summe As Double
Dim Zelle_EIS As Range, ZellePhase As Range
'MsgBox Bereich.Address & vbLf & Bereich1.Address & vbLf & Bereich3.Address
Summe = 0
For Spalte = 1 To Bereich.Columns.Count
'Zelle mit mit E, I oder S in Titelzeile relativ zu Zelle mit Wert bestimmen
Set Zelle_EIS = Bereich.Cells(1, Spalte).Offset(rngEIS.Row - Bereich.Row, 0).Cells(1, 1)
With Zelle_EIS
If .Value = rngEIS.Value Then
'Zelle mit "Plan" oder "Vorschau" in Titelzeile relativ zu Zelle mit E, I oder S _
bestimmen
Select Case UCase(.Value)
Case "E": Set ZellePhase = .Offset(rngPhase.Row - rngEIS.Row, 1) 'in Spalte rechts
Case "I": Set ZellePhase = .Offset(rngPhase.Row - rngEIS.Row, 0) 'in Spalte
Case "S": Set ZellePhase = .Offset(rngPhase.Row - rngEIS.Row, -1) 'in Spaltelinks
End Select
If LCase(ZellePhase.Value) = LCase(rngPhase.Value) _
Or UCase(ZellePhase.Value) = "IST" Then
Summe = Summe + Application.WorksheetFunction.Sum(Bereich.Cells(1, Spalte))
End If
End If
End With
Next
fncSUMME_EIS = Summe
End Function
Sub subSummenformelnEinfuegen()
Dim wks As Worksheet
Dim Spalte1 As Long, SpalteL As Long, Zeile1 As Long, ZeileL As Long, SpalteLW As Long
Dim ZeileEIS As Long, ZeilePhase As Long, StatusCalc As Long
Dim strFormel As String
If MsgBox("Summenformeln im Blatt einfügen?", vbQuestion + vbOKCancel, _
"Makro - subSummenformeln") = vbOK Then
Set wks = ActiveSheet
With wks
ZeilePhase = 1 'Zeile mit "Plan", "Vorschau"
ZeileEIS = 3 'Zeile mit den E-I-S-Werten
Spalte1 = 6 'Spalte F = 1. Spalte deren Werte in Summierung einbezogen werden sollen
Zeile1 = 4 '1. Zeile mit Werten, die in Summierung einbezogen werden soll
'Letzte Zeile mit Einträgen in Spalte A
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row 'bis zu dieser Zeile werden Formeln eingefügt
'Spalte in der letzte Summenformel eingetragen werden soll
SpalteL = .Cells(ZeileEIS, .Columns.Count).End(xlToLeft).Column + 1
'letzte Spalte mit zu summierenden Werten
SpalteLW = SpalteL - 9
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Formel-Plan-EIS
strFormel = "=fncSUMME_EIS(RC6:RC" & SpalteLW & ",R3C[0],R1C" & SpalteL - 6 & ")"
.Range(.Cells(Zeile1, SpalteL - 7), .Cells(ZeileL, SpalteL - 5)).FormulaR1C1 = strFormel
'Formel-Plan-Summe
strFormel = "=SUM(RC[-3]:RC[-1])"
.Range(.Cells(Zeile1, SpalteL - 4), .Cells(ZeileL, SpalteL - 4)).FormulaR1C1 = strFormel
'Formel-Vorschau-EIS
strFormel = "=fncSUMME_EIS(RC6:RC" & SpalteLW & ",R3C[0],R1C" & SpalteL - 2 & ")"
.Range(.Cells(Zeile1, SpalteL - 3), .Cells(ZeileL, SpalteL - 1)).FormulaR1C1 = strFormel
'Formel-Vorschau-Summe
strFormel = "=SUM(RC[-3]:RC[-1])"
.Range(.Cells(Zeile1, SpalteL), .Cells(ZeileL, SpalteL)).FormulaR1C1 = strFormel
.Calculate
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
End With
'Formeln durch Werte ersetzen
'If MsgBox("Summen-Formeln durch Werte ersetzen?", vbQuestion + vbOKCancel, _
' "Makro - subSummenformeln") = vbOK Then
'With .Range(.Cells(Zeile1, SpalteL - 7), .Cells(ZeileL, SpalteL))
' .Value = .Value
'End With
'End If
End With
End If
End Sub
Diese Funktion würde ich jetzt gerne in einem anderen Modul aufrufen bzw. dazubringen "abzulaufen".
@Rudi: Deinen Kommentar es ohne weiteren Text zu versuchen verstehe ich leider nicht.
Vielen Dank
Gruß
Lutz