Guten Tag liebe VBA Experten!

Ich verzweifle ein wenig an der vor mir liegenden Aufgabe und hoffe, dass ich hier vielleicht eine Lösung finde.

Jeden Monat wird eine Tabelle um 2 Spalten ergänzt. Diese Spalten sind ca. 70 Zeilen lang und haben als Überschrift "X" und "Y".

Was ich versuche, ist die Teilsumme dieser Spalten unter jede Spalte mit Überschrift "X" und Überschrift "Y" einzutragen. (es gibt mehrere Spalten mit der Überschrift "X" oder "Y")

Die Überschriften sind immer gleich und stehen immer in Zeile 2.

Um zu verdeutlichen was ich mir vorgestellt habe:

1) Suche in Zeile 2 nach Überschrift "X" und "Y"

2) Wenn Überschrift = "X" oder "Y" dann

     Springe zur letzten genutzten Zelle

     Gehe 2 Zellen weiter runter   'hat den Sinn, eine Zeile Platz zu lassen und das Ergebnis in die nächste Zeile zu schreiben

      Berechne die Teilsumme der Spalte

3) Wiederhole dies für jede Spalte mit Überschrift "X" und "Y"

Ich habe zwar einen Code der das tut was ich möchte, nur leider tut er das immer nur für die ersten beiden Spalten mit den Überschriften, er müsste das aber für jede Spalte mit besagten Überschriften tun.

Option Explicit

Sub Suchen()

Dim rZelleX As Range
Dim rZelleY As Range
Dim sSuchbegriffX  As String: sSuchbegriffX = "X"
Dim sSuchbegriffY  As String: sSuchbegriffY = "Y"
Dim Zelle As Range


With ActiveSheet.Rows(Range("A2").Row)
       Set rZelleX = .Find(What:=sSuchbegriffX, lookat:=xlWhole, LookIn:=xlValues, _
          SearchOrder:=xlByRows)
       Set rZelleY = .Find(What:=sSuchbegriffY, lookat:=xlWhole, LookIn:=xlValues, _
          SearchOrder:=xlByRows)
End With
       

rZelleX.End(xlDown).Offset(2, 0).ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-66]C:R[-2]C)"
rZelleY.End(xlDown).Offset(2, 0). ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-66]C:R[-2]C)"

End Sub



Ich würde mich sehr über eure Hilfe freuen.


Mit freundlichen Grüßen,

Karl