Automatisch Som-formule bereik selecteren in VBA

[Girt04]

Goedemorgen,

Ik hoop dat een van jullie mij kan helpen met de volgende uitdaging. Ik werk in Excel 2016.

Ik ben bezig om een data dump automatisch overzichtelijk te maken voor gebruikers. Ik kom hierbij een heel eind maar nog niet helemaal tot waar ik wil zijn. Ik heb het volgende al voor elkaar gekregen:
1 Voeg na iedere verandering in waarde in kolom B 2 blanco regels in.
2 Voeg in iedere tweede blanco regel de titels (is de waarde eronder) van kolommen A en B weer en maak deze dikgedrukt en kleur de hele regel.

Ik heb een voorbeeld-bestand in de bijlage gedaan. In het voorbeeld bestand heb ik de VBA-code welke ik reeds gemaakt heb nog niet laten draaien, zodat jullie kunnen zien wat het voor en na is.

Het resultaat na het draaien van de VBA-code is de volgende:


Nu wil ik graag in Kolom C in iedere grijze titelregel, zie rode kaders, de som van de regels onder de titel wordt opgeteld. Dit moet het totaal voor dat blok worden.
Ik krijg dit alleen niet voor elkaar, ik hoop dat iemand mij kan helpen.

Alvast bedankt.

Girt04

Bekijk bijlage Voorbeeld rapport.xlsm

 

[E v R]

al iets ingekort:

Sub MacroRapport()

'Lege regels invoegen na ieder promotieblok en promotieblok naam in titelregel toevoegen.
    Dim I As Long, J As Long, K As Long, L As Long
    J = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
    L = J + 2
    For I = J To 2 Step -1
      
        If Range("B" & I).Value <> Range("B" & I - 1).Value Then
        K = I + 2
            Range("B" & I).EntireRow.Insert Shift:=xlDown
            Range("B" & I).EntireRow.Insert Shift:=xlDown
            Range("C" & I + 1).Formula = "=SUM(C" & K & ":C" & L & ")"
        L = K - 1
        End If
        If Range("B" & I).Value = "" And Range("B" & I - 1).Value <> "" Then
            Range("B" & I + 1).Value = Range("B" & I + 2).Value
            Range("B" & I + 1).Font.FontStyle = "Bold"
            Range("B" & I + 1).EntireRow.Interior.ColorIndex = 15
        End If
        
        If Range("A" & I).Value = "" And Range("A" & I - 1).Value <> "" Then
            Range("A" & I + 1).Value = Range("A" & I + 2).Value
            Range("A" & I + 1).Font.FontStyle = "Bold"
        End If
        
    Next I



'Bericht rapport klaar
    MsgBox "Rapport is klaar voor gebruik."


End Sub

 

[Haije]

welkom op Helpmij.nl

zie bijlage

 

[VenA]

Iets verder ingekort.

Sub VenA()
  For J = Columns(2).SpecialCells(2).Count To 2 Step -1
    If Cells(J, 2) <> Cells(J - 1, 2) Then Rows(J).Resize(2).Insert
  Next
  For Each ar In Columns(1).SpecialCells(2, 1).Areas
    With ar
      .Cells(1).Offset(-1).Resize(, 3) = Array(.Cells(1), .Cells(1).Offset(, 1), Application.Sum(.Offset(, 2)))
      .Cells(1).Offset(-1).Resize(, 3).Font.Bold = True
      .Cells(1).Offset(-1).Resize(, 3).Interior.ColorIndex = 15
    End With
  Next
End Sub

 

[Girt04]

VenA, Haije en E v R,

Super bedankt voor jullie reacties!!

Het werkt