Filter für Zeilenwert Addition

Option Explicit

Private Type MyWerte_struct
  lZeile As Long
  dWert  As Double
End Type

'******************************************************************
Sub SuchenIn2SpaltenUndSpezSumme()

'< < < A N P A S S E N > > >
  Const cZ_ERSTESUCHZEILE = 2         ->muß >= 2 sein !!!
  Const cZ_LETZTESUCHZEILE = 2999
  Const cSP_SPALTE_FUER_SUCHBEGRIFF_1 = 6->entspricht F
  Const cSP_SPALTE_FUER_SUCHBEGRIFF_2 = 5->entspricht E
  Const cSP_SPALTE_FUER_SUMMANDEN = 8     'entspricht H
'< < < A N P A S S E N    E N D E > > >
  
  Dim wb As Workbook, ws As Worksheet
  Dim wbt As Workbook, wst As Worksheet
  Dim sSuchbeg1 As String, sSuchbeg2 As String
  
  
 ->Suchbegriffe abfragen
  sSuchbeg1 = InputBox( _
    Eingabe für Suchbegriff 1, Hudsons Erleichterung, )
  If sSuchbeg1 =  Then Exit Sub
   
  sSuchbeg2 = InputBox( _
    Eingabe für Suchbegriff 2, Hudsons Erleichterung, )
    
 ->Nachfrage, ob Suchbegriffe i.O.
  If Not vbYes = MsgBox( _
    Folgende Suchbegriffe wurden eingegeben: & vbLf & _
    Suchbegriff1:  & sSuchbeg1 & vbLf & _
    Suchbegriff2:  & sSuchbeg2 & vbLf & vbLf & _
    Fortgefahren ??? , _
    vbYesNo + vbQuestion + vbDefaultButton1) Then Exit Sub

 ->aktive Mappe/Blatt
  Set wb = ActiveWorkbook: Set ws = ActiveSheet
  
 ->temp. Mappe anlegen
  Set wbt = Workbooks.Add: Set wst = wbt.Worksheets(1)
  
  Call SoTunAlsOb(ws, wst, _
                  sSuchbeg1, cSP_SPALTE_FUER_SUCHBEGRIFF_1, _
                  sSuchbeg2, cSP_SPALTE_FUER_SUCHBEGRIFF_2, _
                  cZ_ERSTESUCHZEILE, cZ_LETZTESUCHZEILE, _
                  cSP_SPALTE_FUER_SUMMANDEN)
  
    
AUFRAEUMEN:
  wbt.Activate
  Set wb = Nothing: Set ws = Nothing
  Set wbt = Nothing: Set wst = Nothing
End Sub

'******************************************************************
Function SoTunAlsOb(ws As Worksheet, wst As Worksheet, _
                    sSB1 As String, lSP1 As Long, _
                    sSB2 As String, lSP2 As Long, _
                    lZAnf As Long, lZEnd As Long, _
                    lSPWert As Long)

  Dim r As Range, Zelle As Range
  Dim lZA As Long, lZE As Long
  Dim fW() As MyWerte_struct, fWCnt As Long
  Dim x As Long, lZtCnt As Long, dWert As Double, dGesSum As Double
    
  lZA = lZAnf - 1
  lZE = lZEnd
  fWCnt = 0: ReDim fW(1 To 100)
  
 Do
  
    If lZA < lZE Then
      Set r = ws.Range(ws.Cells(lZA, lSP1), ws.Cells(lZE, lSP1))
      Set Zelle = r.Find( _
                    What:=sSB1, _
                    After:=ws.Cells(lZA, lSP1), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchDirection:=xlPrevious)
      
      If Zelle Is Nothing Then Exit Do
      
      If sSB2 = ws.Cells(Zelle.Row, lSP2).Value Then
       ->*** Zeile mit Suchbegriff1 und 2 gefunden

       ->Summanden aus der nächsten Zeile lesen
        dWert = ws.Cells(Zelle.Row + 1, lSPWert).Value
        
       ->In Feld merken
        fWCnt = fWCnt + 1
        If UBound(fW()) < fWCnt Then ReDim Preserve fW(1 To fWCnt + 100)
        fW(fWCnt).lZeile = Zelle.Row
        fW(fWCnt).dWert = dWert
        
      End If
  
      lZE = Zelle.Row - 1
    Else
      Exit Do
    End If
  Loop
  
 ->gemerkte Werte auf tmp. Workbook ausgeben
 ->Überschriften in tmp. Workbook
  lZtCnt = 1
  wst.Cells(lZtCnt, 1).Value = Zeile
  wst.Cells(lZtCnt, 2).Value = Wert
  wst.Cells(lZtCnt, 3).Value = Summe
  dGesSum = 0#
  For x = fWCnt To 1 Step -1
    lZtCnt = lZtCnt + 1
    wst.Cells(lZtCnt, 1).Value = fW(x).lZeile
    wst.Cells(lZtCnt, 2).Value = fW(x).dWert
    dGesSum = dGesSum + fW(x).dWert
    wst.Cells(lZtCnt, 3).Value = dGesSum
  Next
  
AUFRAEUMEN:
  Set r = Nothing: Set Zelle = Nothing
End Function