Subtotaal in Excel in combinatie met VBA

[AEHofman]

Hallo

Ik heb een oplossing nodig om een rapport gemaakt met de functie subtotaal, te verfijnen.
Het rapport maken gaat prima maar, ik wil graag dat een stukje VBA code het rapport netjes oplevert.
En daar zit het probleem. In kolom B laat ik via VBA de omschrijving invoeren, maar hij moet dan stoppen als hij de laatste cel heeft bereikt en dat doet hij niet, zie foto.
Als bijlage het voorbeeldbestand.

Alvast bedankt

Andrys

 

[HSV]

Is dit niet voldoende?

Sub Tabel_Opvullen()
Application.ScreenUpdating = False
 With Sheets("Blad1")
   .Cells(1).CurrentRegion.Columns(1).Resize(, 3).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _
        Replace:=False, PageBreaks:=False, SummaryBelowData:=True
   .Outline.ShowLevels RowLevels:=2
 End With
End Sub

 

[AEHofman]

Omschrijvingen missen nog.

Hoi Harry,
Alvast bedankt voor jouw reactie.

Ik heb nu alleen jouw code ingevoerd (zit onder de knop Rapport maken).
Na het aanmaken van het rapport met deze code worden de omschrijvingen niet getoond in kolom "B".
Deze omschrijvingen moeten er wel in komen te staan.

Anders kunnen de medewerkers niet de juiste hoeveelheden gebak apart zetten die zijn besteld voor klanten.
Want daar is het maken van dit raport voor bedoelt.
Even als voorbeeld omschrijvingen aangepast.

Andrys


Bekijk bijlage 236317[/ATTACH]

 

[HSV]

Zoiets?

 .Outline.ShowLevels RowLevels:=3

 

[VenA]

Inclusief opmaak en het verbergen van 'lege regels' kom ik tot deze

Sub VenA()
With Sheets("Blad1")
    .Cells(1).CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    .Outline.ShowLevels RowLevels:=2
    lr = .Columns(1).Find("Eindtotaal", , xlValues, xlWhole).Row
    Rows(lr).EntireRow.Delete
    For Each cl In .Columns(1).SpecialCells(2)
        If Left(cl.Value, 6) = "Totaal" Or Left(cl.Value, 5) = "Total" Then
            cl.Offset(, 1).Value = cl.Offset(-1, 1).Value
            For jj = 0 To 4
            With cl.Offset(, jj)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
            End With
            Next jj
        End If
        lr1 = cl.Row
    Next cl
    Rows(lr1 + 1 & ":" & lr).EntireRow.Hidden = True
End With
End Sub

 

[AEHofman]

Is een mogelijkheid.

Dat is wel een mogelijkheid, maar in dit voorbeeld bestand, is maar een deel van de werkelijke aantallen en soorten gebruikt.
In werkelijkheid kunnen het nog meer soorten zijn.
En dan komt het de overzichtelijkheid niet ten goede.
In het originele bestand zat het toevoegen van de omschrijvingen er wel in maar hij stopt niet op het juiste punt.
Dat is toch wat ik het liefste zou willen gebruiken.

Andrys

 

[AEHofman]

Opgelost

Hoi VenA

Deze code doet precies wat ik nodig heb.
Bedankt voor de oplossing.

Ik zal de vraag als opgelost markeren.

 

[VenA]

Je moet nog wel de code onder de knop 'Rapport Verwijderen' aanpassen in bv

Private Sub CommandButton1_Click()
With ActiveSheet.Cells
    .RemoveSubtotal
    .Rows.EntireRow.Hidden = False
End With
End Sub

Anders blijven de rijen verborgen

 

[HSV]

Dat was dus de bedoeling.
Dat kan zonder een loopje wat sneller gaat.

If Left(cl.Value, 6) = "Totaal" Or Left(cl.Value, 5) = "Total" Then
            cl.Offset(, 1).Value = cl.Offset(-1, 1).Value
            cl.Resize(, 5).BorderAround xlContinuous, xlThin, -4105
             cl.Resize(, 5).Borders(xlInsideHorizontal).LineStyle = xlContinuous
             cl.Resize(, 5).Borders(xlInsideVertical).LineStyle = xlContinuous
        End If

 

[HSV]

Geen enkele lus nodig eigenlijk.

Sub hsv()
With Sheets("Blad1")
    .Cells(1).CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    .Outline.ShowLevels RowLevels:=2
    .Columns(1).Find("Eindtotaal", , xlValues, xlWhole).EntireRow.Hidden = True
    .Cells(1).CurrentRegion.Columns(2).SpecialCells(4) = "=r[-1]c"
    With Columns(1).SpecialCells(2).Offset(, 1)
       .Value = .Value
    End With
   With .Cells(1).CurrentRegion.Resize(, 5)
     .BorderAround xlContinuous, xlThin, -4105
     .Borders(xlInsideHorizontal).LineStyle = xlContinuous
     .Borders(xlInsideVertical).LineStyle = xlContinuous
   End With
 End With
End Sub