macro (of VBA) voor ingewikkelde opmaak + voorbeeldbestand

[renew000]

Hallo experts,

Op dit moment ben ik bezig met een bestandje waarmee een aantal gegevens wil kunnen opmaken, maar helaas zit ik nu een beetje vast.

Op dit moment is het wel met hulp gelukt om ervoor te zorgen dat er op kolom B wordt gesorteerd om vervolgens tussen elk soort product 3 witregels te zetten.
Deze acties zitten opgesloten in een macro waarvoor een knop is gemaakt.

Wat ik nu heel graag zou willen is dat er per productgroep een som wordt toegepast, die ervoor zorgt dat ik het totale bedrag per productgroep kan laten zien.
Deze som-functie zou dan op de eerste witregel (die door de macro hiervoor is gecreëerd) in kolom moeten worden weergegeven.
Om voor extra duidelijkheid te zorgen zou er, als extra eigenschappen aan deze waarden, gebruik kunnen worden gemaakt van het dikgedrukt maken, fontkleur wijzigen en een lijn aan de bovenkant van cel.

Voor de duidelijkheid heb ik een voorbeeldbestand gemaakt. Op tabblad 1 staat het formulier met de knop voor het sorteren.
Op tabblad 2 heb ik de opmaak gemaakt zoals die voor mij het beste zou werken.

Ik hoop dat het mogelijk is om alles onder dezelfde macro te zetten die ook de gegevens sorteert en voor de witregels zorgt.
Als het natuurlijk al wel mogelijk is.

In ieder geval alvast hartstikke bedankt voor jullie hulp

groetjes

 

[exopad]

Hallo,

Dit is niet zo ingewikkeld als het lijkt.
Hieronder een stukje code dat dit kan bewerkstelligen:

__________

Sub testopmaak()

Sheets("Blad1").Select
    Columns("A:C").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    Range("A1").Select
    
    
i = 2
Do
If Range("B" & i) <> Range("B" & i + 1) Then
Rows(i + 1).Select
    Selection.Insert Shift:=xlDown
    Selection.Insert Shift:=xlDown
    Selection.Insert Shift:=xlDown
    Range("C" & i).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    Range("C" & i + 1).Select
    
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Font.Bold = True
    Selection.Font.ColorIndex = 3
   ActiveCell.FormulaR1C1 = "=SUMIF(C[-1],R[-1]C[-1],C)"

i = i + 4
Else
i = i + 1
End If

Loop Until Range("B" & i) = ""


End Sub

_________

De formules die je op blad2 hebt gebruikt, zijn overigens niet juist. In plaats van een somfunctie, kun je beter een som.als gaan gebruiken. Dit werkt makkelijker wanneer het bereik dynamisch is.

 

[renew000]

Wow... thanks exopad... dit is echt precies wat ik zocht... nogmaals thanks... ik ga em sluiten

 

[huijb]

@exopad code dient tussen de codetags geplaatst te worden. Selecteer de code en klik op #

 

[renew000]

@exopad: Dacht dat alles in kannen en kruiken was, maar merkte toch op dat ik tegen een "struikelblok" oploop.

In mijn voorbeeldbestand heb ik namelijk maar 3 kolommen gebruikt, terwijl de kolommen in mijn echte bestand er sprake is van 13 kolommen.
In kolom H staan de bruto bedragen. Nu wordt er door een eerdere macro een kolom (genaamd "netto bedragen") achter de kolom bruto bedragen ingevoegd.
De code moet dus eigenlijk van toepassing worden op de kolom "netto bedragen" (wordt dus kolom I).

Omdat het echte bestand nogal gevoelige informatie bevat heb ik in een nieuw voorbeeld de tussenliggende kolommen maar de naam "kenmerk 1" enz gegeven.

Ik hoop dat je me kunt helpen, want de opmaak krijg ik wel aangepast (streep, rood en vetgedrukt), maar bij de som pakt hij dan de verkeerde gegevens
Het zal dan vast liggen aan de zin... ActiveCell.FormulaR1C1 = "=SUMIF(C[-1],R[-1]C[-1],I)"

Alvast bedankt

Greetz

 

[exopad]

In de code moet er wat worden opgeschoven en moet ipv kolom C naar kolom H worden verwezen.
Ook het sorteerbereik moet worden aangepast.

Onderstaand de aangepaste code:

Sub testopmaak()

Sheets("Blad1").Select
    Columns("A:M").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    Range("A1").Select
    
    
i = 2
Do
If Range("B" & i) <> Range("B" & i + 1) Then
Rows(i + 1).Select
    Selection.Insert Shift:=xlDown
    Selection.Insert Shift:=xlDown
    Selection.Insert Shift:=xlDown
    Range("H" & i).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    Range("H" & i + 1).Select
    
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Font.Bold = True
    Selection.Font.ColorIndex = 3
   ActiveCell.FormulaR1C1 = "=SUMIF(C[-6],R[-1]C[-6],C)"

i = i + 4
Else
i = i + 1
End If

Loop Until Range("B" & i) = ""


End Sub

 

[huijb]

@exopad code dient tussen de codetags geplaatst te worden. Selecteer de code en klik op #

Ik herhaal mijzelf