indsætte tomme linjer når der er ændring i tal i kol C

Prøv denne,men numrene i kolonne C skal så stå i grupper.

Public Sub SupTotal()
    Dim RW As Long, intI As Long
    ' ***********************************laver de 2 linjer
    RW = Range("C65536").End(xlUp).Row
    For intI = RW To 5 Step -1
        If Cells(intI, 3) <> Cells(intI - 1, 3) Then
            Rows(intI & ":" & intI + 1).Insert Shift:=xlDown
        End If
    Next

    ' *************************** laver sum på alle  - den sidste
    RW = Range("C5").Row
    On Error GoTo Slut
    Do Until RW > Range("C65536").End(xlUp).Offset(2, 0).Row
        intI = Range("E" & RW).End(xlDown).Row
        If Range("E" & intI).Offset(2, 0) = "" Then
        Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        Else
        intI = RW
        Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        End If
        RW = Range("E" & RW).End(xlDown).Offset(2, 0).Row
    Loop
Slut:
  ' ********** Denne finder den sidste, der skal have sum på
    intI = Range("E65536").End(xlUp).Row
    Range("E65536").End(xlUp).Select
    RW = Selection.End(xlUp).Row
    If Range("E" & RW).Offset(1, 0) = "" Then
        RW = Selection.Row
    End If
    Range("E65536").End(xlUp).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
End Sub

læg mærke til at den starter i række 5
her
  For intI = RW To 5 Step -1

og her
  RW = Range("C5").Row


hvis den første datalinje er i række 5, bør denne
For intI = RW To 5 Step -1
rettes til

For intI = RW To 6 Step -1

fordi jeg tjekker på den ovenover

Jep, lige i øjet igen.

Jeg har forsøgt at få den til at lave en streg over og under alle sammentællinger, men kan ikke få det til at virke, kan du :-)

Kunne det evt lige her på falderebet lade sig gøre at den laver en overskrift med fed i kolonne A udfra det nr der står kol. c ("Nr." + tal)

Overskriften skal så være i nr. 2 tomme linje som lige er blevet sat ind.

Jeg ville gerne have oprettet et nyt spørgsmål til dette, men der er pt ikke flere points på kontoen.

Hvis ikke smider du bare et svar for du har løst mit oprindelige problem fuldt ud.
Mange tak for indsatsen

Public Sub SupTotal()
    Dim RW As Long, intI As Long
    ' ***********************************laver de 2 linjer
    RW = Range("C65536").End(xlUp).Row
    For intI = RW To 6 Step -1
        If Cells(intI, 3) <> Cells(intI - 1, 3) Then
            Rows(intI & ":" & intI + 1).Insert Shift:=xlDown
        End If
    Next

    ' *************************** laver sum på alle  - den sidste
    RW = Range("C5").Row
    On Error GoTo Slut
    Do Until RW > Range("C65536").End(xlUp).Offset(2, 0).Row
        intI = Range("E" & RW).End(xlDown).Row
        If Range("E" & intI).Offset(2, 0) = "" Then
        Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        Else
        intI = RW
        Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        End If
        Range("E" & intI).Offset(1, -4) = "NR. " & Range("E" & intI).Offset(0, -2)
        Call Streg_Fed(Range(Range("A" & intI), Range("E" & intI)).Offset(1, 0))
        RW = Range("E" & RW).End(xlDown).Offset(2, 0).Row
    Loop
    Exit Sub
Slut:
  ' ********** Denne finder den sidste, der skal have sum på
    intI = Range("E65536").End(xlUp).Row
    Range("E65536").End(xlUp).Select
    RW = Selection.End(xlUp).Row
    If Range("E" & RW).Offset(1, 0) = "" Then
        RW = Selection.Row
    End If
    Range("E65536").End(xlUp).Offset(1, -4) = "NR. " & Range("E65536").End(xlUp).Offset(0, -2)
    Call Streg_Fed(Range(Range("A" & intI), Range("E" & intI)).Offset(1, 0))
    Range("E65536").End(xlUp).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
 
End Sub
Sub Streg_Fed(rng As Range)
With rng
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Font.Bold = True
    End With
End Sub

Ved nærmere studering af koden laver den desværre fejl.
Hvis der er mere end 1 linje i hver gruppe så sletter den beløbet i kolonne e i den nederste linje og indsætter sammentællingen istedet.

Den skal helst lave sammentællingen på linjen lige nedenunder den sidste linje i hver gruppe.

Jeg ved godt at det er ekstra jeg spørger efter, men jeg prøver alligevel :-)

Kan nr. fra kolonne C komme til at stå lige over den øverste linje i hver gruppe, så det bliver en slags overskrift i kolonne A. ("nr" + tal)
Lige nu sætter den det i samme linje som sammentællingen.

Jeg kan ikke få den til at slette nederste linje, jeg har tjekket.
Det med overskrift, skulle være der nu.

Public Sub SupTotal()
    Dim RW As Long, intI As Long
    ' ***********************************laver de 2 linjer
    RW = Range("C65536").End(xlUp).Row
    For intI = RW To 6 Step -1
        If Cells(intI, 3) <> Cells(intI - 1, 3) Then
            Rows(intI & ":" & intI + 1).Insert Shift:=xlDown
        End If
    Next

    ' *************************** laver sum på alle  - den sidste
    RW = Range("C5").Row
    On Error GoTo Slut
    Do Until RW > Range("C65536").End(xlUp).Offset(2, 0).Row
        intI = Range("E" & RW).End(xlDown).Row
        If Range("E" & intI).Offset(2, 0) = "" Then
            Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        Else
            intI = RW
            Range("E" & intI).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"
        End If
        Range("E" & RW).Offset(-1, -4) = "NR. " & Range("E" & intI).Offset(0, -2)
        Range("E" & RW).Offset(-1, -4).Font.Bold = True
        Call Streg_Fed(Range(Range("A" & intI), Range("E" & intI)).Offset(1, 0))
        RW = Range("E" & RW).End(xlDown).Offset(2, 0).Row
    Loop
    Exit Sub
Slut:
    ' ********** Denne finder den sidste, der skal have sum på
    intI = Range("E65536").End(xlUp).Row
    Range("E65536").End(xlUp).Select
    RW = Selection.End(xlUp).Row
    If Range("E" & RW).Offset(1, 0) = "" Then
        RW = Selection.Row
    End If
    Range("E" & RW).Offset(-1, -4) = "NR. " & Range("E" & RW).Offset(0, -2)
    Range("E" & RW).Offset(-1, -4).Font.Bold = True
    Call Streg_Fed(Range(Range("A" & intI), Range("E" & intI)).Offset(1, 0))
    Range("E65536").End(xlUp).Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & (intI - RW) + 1 & "]C:R[-1]C)"

End Sub
Sub Streg_Fed(rng As Range)
    With rng
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Font.Bold = True
    End With
End Sub

Den driller desværre lidt endnu.


Den har problemer hvis alle grupperne kun har 1 eller 2 linjer. Kan ikke lige se hvorfor.

Overskriften i kolonne A skal stå i en linje helt for sig selv.
Sammentælling i kolonne E skal stå i en linje for sig selv

Pt indsætter den 2 tomme linjer imellem hver gruppe. det skulle måske udviddes til 3 linjer for overskuelighedens skyld. Men det er jo det mindste af det.

Jeg har rettet lidt i understregning, så den kun laver understregning i kol E

Call Streg_Fed(Range(Range("E" & intI), Range("E" & intI)).Offset(1, 0))

Kabbak, kan du godt få den til at lave en korrekt sammentælling på alle grupper.
Både grupper med 1 og 2 og 3 uden at den laver sammentælling i en af "ikke tomme" linjer?

Uanset om der er 1, 2, 3 eller flere, er summen placeret korrekt, hos mig.

Det er ikke sådan at du har flettede celler i området ??.

Jeg har ingen flettede celler i arket.

Jeg prøver lige opremse hvordan mit ark ser ud.
** Jeg starter med at have noget i linje 5
** Der står noget i kolonne a+b+c+d+e+f i alle disse linjer.
** jeg har 14 linjer i mit testark
** grupperne/tallene i kol c i de 14 linjer ser således ud 13590, 13591,13592,13593,13594,13595,13596,13597,13597,13598,13598,13599,13599,13600

Public Sub SupTotal2()
    Dim RW As Long, intI As Long, I As Long, X As Long
    ' ***********************************laver de 2 linjer
    RW = Range("C65536").End(xlUp).Row
    For intI = RW To 6 Step -1
        If Cells(intI, 3) <> Cells(intI - 1, 3) Then
            Rows(intI & ":" & intI + 1).Insert Shift:=xlDown
        End If
    Next

    ' *************************** laver sum på alle  - den sidste
    RW = Range("C5").Row
    intI = Range("C65536").End(xlUp).Row + 2
    X = RW
    For I = RW To intI
        If Range("E" & I) = "" Then
            Range("E" & I).FormulaR1C1 = "=SUM(R[-" & (I - X) & "]C:R[-1]C)"
            Call Streg_Fed(Range("E" & I))
            Range("E" & X).Offset(-1, -4) = "NR. " & Range("E" & I).Offset(-1, -2)
            Range("E" & X).Offset(-1, -4).Font.Bold = True
            RW = Range("E" & I).Offset(2, 0).Row
            X = RW
            I = I + 2
        End If
    Next
   
End Sub

Så var den der.
Fuldstændig som ønsket.
Mange tak for hjælpen incl. de ekstra ønsker :-)