Rij (subtotaal) bold maken

[Veerus]

Zo weer terug op het forum, ik probeer subtotalen bold te krijgen maar ik krijg het niet voor elkaar....ik hoop dat iemand hier op het forum even zou willen meekijken.

Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5, 9, 11, 12, 13 _
        , 14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Het eerste deel wordt alleen bold maar ik zou graag zien dat de hele rij bold wordt
Dit geldt ook voor het eindtotaal

Ik heb ook de excel file ff bijgevoegd, als iemand een idee heeft dan hoor ik het graag

 

[Warme bakkertje]

Test deze eens

Sub Groeperen()
    With Sheets("calculations").UsedRange
        .RemoveSubtotal
        .ClearContents
    End With
    Sheets("CI & PL").UsedRange.ClearContents
    Sheets("original").UsedRange.Copy Sheets("calculations").Range("A1")
    With Sheets("calculations")
    Dim l As Long
        For l = .Range("A" & .Rows.Count).End(xlUp).Row To 3 Step -1
            If .Range("A" & l).Value <> .Range("A" & l - 1).Value Then
                .Rows(l).Insert
            End If
        Next
        .UsedRange.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5, 9, 11, 12, 13 _
        , 14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .Outline.ShowLevels 2
        .UsedRange.SpecialCells(xlCellTypeVisible).Font.Bold = True
    .Range("A1:S100").Copy Sheets("CI & PL").Range("A7")
   End With
    With Sheets("CI & PL")
        .Columns("B:C").EntireColumn.AutoFit
        .Columns("E:E").EntireColumn.AutoFit
        .Columns("G:G").ColumnWidth = 12.57
        .Columns("I:J").EntireColumn.AutoFit
        .Columns("N:S").EntireColumn.AutoFit
        .Columns("B:B").Delete Shift:=xlToLeft
        .Columns("A:A").Insert Shift:=xlToRight
        .Range("B7").Copy .Range("A7")
        .Range("A7") = "CTN nr."
    End With
End Sub

 

[Veerus]

Thanks dat is weer een andere aanpak waar ik even niet aan had gedacht, na dit toegepast te hebben loop ik echter tegen het volgende probleem aan:
De bovenste zes rijen verdwijnen ook terwijl de Range zou moeten beginnen op A7

 

[HSV]

Probeer het zo eens.

Sub Groeperen()
    With Sheets("calculations").UsedRange
        .RemoveSubtotal
        .ClearContents
    End With
   [COLOR="red"]With Sheets("CI & PL")
   Dim rij As Long
      For rij = .Cells(.Rows.Count, 2).End(xlUp).Row To 7 Step -1
        If .Cells(rij, 2) <> "" Then
         .Rows(rij).ClearContents
        End If
      Next rij
    End With[/COLOR]    
Sheets("original").UsedRange.Copy Sheets("calculations").Range("A1")
    With Sheets("calculations")
    Dim l As Long
        For l = .Range("A" & .Rows.Count).End(xlUp).Row To 3 Step -1
            If .Range("A" & l).Value <> .Range("A" & l - 1).Value Then
                .Rows(l).Insert
            End If
        Next
        .UsedRange.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5, 9, 11, 12, 13 _
        , 14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .Outline.ShowLevels 2
        .UsedRange.SpecialCells(xlCellTypeVisible).Font.Bold = True
    .Range("A1:S100").Copy Sheets("CI & PL").Range("A7")
   End With
    With Sheets("CI & PL")
        .Columns("B:C").EntireColumn.AutoFit
        .Columns("E:E").EntireColumn.AutoFit
        .Columns("G:G").ColumnWidth = 12.57
        .Columns("I:J").EntireColumn.AutoFit
        .Columns("N:S").EntireColumn.AutoFit
        .Columns("B:B").Delete Shift:=xlToLeft
        .Columns("A:A").Insert Shift:=xlToRight
        .Range("B7").Copy .Range("A7")
        .Range("A7") = "CTN nr."
    End With
End Sub

 

[Warme bakkertje]

Of

With Sheets("CI & PL")
    .Range("A8:S" & .Cells(Rows.Count, 2).End(xlUp).Row).ClearContents
End With

 

[HSV]

Als er nog niets is ingevuld, behalve de eerste 6 rijen, zal het toch weer de eerste 6 rijen wissen Rudi.
Dus alleen bij de eerste keer de macro laten lopen.

anders.

With Sheets("CI & PL")
    .Range("A8:S" & .Cells(Rows.Count, [COLOR="red"]3[/COLOR]).End(xlUp).Row [COLOR="red"]+ 1[/COLOR]).ClearContents
End With

 

[Veerus]

Top Thanks dit forum is wel echt handig hoor (zowel Harry als Rudi oplossing werkte trouwens)