Sous totaux VBA
Bonjour,
Je dois formater une sortie de notre logiciel comptable vers EXCEL pour présenter un rapport d'inventaire.
Je joins un fichier pour montrer mon problème.
J'ai des numéros de produits débutant par 01, 02, 03 ... etc. qui appartiennent à des catégories de produits différents. Pour la majorité, je n'ai pas de problème à faire mon sous-total à chaque changement des 2 premiers chiffres ou caractères de mes SKUs.
Par contre, j'ai une catégorie qui comporte beaucoup de SKUs et donc les numéros débutants par 70, 71 et 72 sont du même groupe et je veux un sous-total seulement à la fin de tout les skus débutants par un 7 finalement.
Je ne sais pas trop comment le gérer. Je joins ce que j'ai déjà qui fonctionne à l'exception qu'il me sépare les 70, 71 et 72. Dans le fichier EXCEL, j'ai placé un échantillon des données dans un onglet et le résultat souhaité dans l'autre.
Espérant qu'une des talentueuses personnes de ce site ai une piste de solution pour moi
Merci à l'avance.
Sub SousTotaux()
'
' Ajouter les sous-totaux et leur description
'
Dim i As Integer
Dim Iprec As Integer
i = 3
Iprec = 3
'Boucle sur tant que la colonne A n'est pas vide
Do While Range("A" & i).Value <> ""
'Si 2 premiers chiffres du sku <> des 2 premiers chiffres du sku précédent
If Mid(Cells(i, 1).Value, 1, 2) <> Mid(Cells(i + 1, 1).Value, 1, 2) Then
'insère 2 lignes
Rows(i + 1).Insert
Rows(i + 1).Insert
'insère la somme du groupe
Range("E" & i + 1).FormulaLocal = "=somme(E" & Iprec & ":E" & i & ")"
'Mettre en gras et mettre une ligne au dessus du total
Range("E" & i + 1).Font.Bold = True
Range("E" & i + 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
Range("D" & i + 1).Select
If Mid(Cells(i, 1).Value, 1, 2) = "01" Then Cells(i + 1, 4).Value = "TOTAL GÉOTEXTILE"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "02" Then Cells(i + 1, 4).Value = "TOTAL GÉOGRILLE"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "03" Then Cells(i + 1, 4).Value = "TOTAL GÉOMEMBRANE"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "04" Then Cells(i + 1, 4).Value = "TOTAL MUR DE SOUTÈNEMENT"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "05" Then Cells(i + 1, 4).Value = "TOTAL CONTRÔLE DE L'ÉROSION CT"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "06" Then Cells(i + 1, 4).Value = "TOTAL CONTRÔLE DE L'ÉROSION MT"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "07" Then Cells(i + 1, 4).Value = "TOTAL CONTRÔLE DE L'ÉROSION LT"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "08" Then Cells(i + 1, 4).Value = "TOTAL DRAINAGE"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "10" Then Cells(i + 1, 4).Value = "TOTAL PRODUITS DIVERS"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "30" Then Cells(i + 1, 4).Value = "TOTAL VÉGÉTALISATION URBAINE"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "72" Then Cells(i + 1, 4).Value = "TOTAL GABIO"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
If Mid(Cells(i, 1).Value, 1, 2) = "Pl" Then Cells(i + 1, 4).Value = "TOTAL PLANS SCELLÉS ET SIGNÉS"
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
End With
'mémorise la ligne de début de la prochaine section
Iprec = i + 3
i = i + 2
Else
Iprec = Iprec
End If
i = i + 1
Loop
End SubBonjour Gibri,
Il y a peut-être un peu plus optimisé en code et qui traite les SKUs
Sub SousTotaux()
Dim dLig As Long, fLig As Long, Lig As Long, nLig As Long
Dim ShtD As Worksheet, ShtS As Worksheet
Dim DebCode As String, MemCode As String, sType As String
' Définir la feuille source et de destination
Set ShtS = Sheets("Données")
Set ShtD = Sheets("Résultats")
' Dernière ligne de la feuille source
dLig = ShtS.Range("A" & Rows.Count).End(xlUp).Row
' Parcourir chaque ligne
For Lig = 1 To dLig
If ShtS.Range("D" & Lig) = "" Then GoTo SuiteLig
' Récuperer les 2 premiers caractères du code
DebCode = Left(ShtS.Range("A" & Lig), 2)
If Left(DebCode, 1) = "7" Then DebCode = "7"
'
If MemCode = "" Then MemCode = DebCode
If MemCode = DebCode Then
nLig = ShtD.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Row
ShtS.Rows(Lig).Copy Destination:=ShtD.Range("A" & nLig)
' Récupérer le type de produit pour les sous-totaux
If DebCode <> "7" Then
sType = Left(ShtS.Range("B" & Lig), InStr(1, ShtS.Range("B" & Lig), " ") - 1)
Else
sType = "SKUs"
End If
Else
' Nouveau code, on fait donc le TOTAL
' Récuperer la première ligne du type de produit
fLig = ShtD.Range("D" & nLig).End(xlUp).Offset(1, 0).Row
' Nouvelle ligne
nLig = ShtD.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Row
' Inscrire le total
With ShtD.Range("D" & nLig)
.Value = "TOTAL " & sType
.HorizontalAlignment = xlRight
End With
With ShtD.Range("E" & nLig)
.FormulaLocal = "=SOMME(E" & fLig & ":E" & nLig - 1 & ")"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
' On mémorise le nouveau code
MemCode = DebCode
' Prochaine ligne en insérant une ligne vierge
nLig = ShtD.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Row + 1
' On copie la nouvelle ligne
ShtS.Rows(Lig).Copy Destination:=ShtD.Range("A" & nLig)
' Récupérer le type de produit pour les sous-totaux
If DebCode <> "7" Then
sType = Left(ShtS.Range("B" & Lig), InStr(1, ShtS.Range("B" & Lig), " ") - 1)
Else
sType = "SKUs"
End If
End If
ShtD.Columns("B:B").AutoFit
ShtD.Columns("E:E").AutoFit
SuiteLig:
Next Lig
Set ShtD = Nothing: Set ShtS = Nothing
End SubA voir
Bonjour,
Je vais voir comment adapter le tout. En fait, dans mon fichier, j'ai mis 2 onglets pour voir le avant après, mais dans les faits, cette sub doit s'exécuter dans la même page que les données. Elle est une parmi plusieurs subs à s'exécuter. De plus, le descriptif après le mot TOTAL ne vient pas du nom de produit. Dans mon exemple, on dirait que oui, mais j'ai mis un petit échantillon de nos ± 1 000 SKUs.
J'adapte et vous reviens.
En attendant, merci beaucoup.
Bon, j'avoue ne pas avoir compris à 100% ce code, mais j'arrive à 99% du résultat souhaité.
J'ai dû ajouter un - 1 après le fLig dans la ligne suivante, car ça ne prenait pas la première ligne du groupe dans le total.
.FormulaLocal = "=SOMME(E" & fLig - 1 & ":E" & nLig - 1 & ")"Pour mes titres de TOTAL, j'ai utilisé la fonction Select Case afin d'assigner le bon nom de groupe.
Select Case DebCode
Case "01"
sType = " GÉOTEXTILE"
Case "02"
sType = " GÉOGRILLE"
Case "03"
sType = " GÉOMEMBRANE"
Case "04"
sType = " MUR DE SOUTÈNEMENT"
Case "05"
sType = " CONTRÔLE DE L'ÉROSION CT"
Case "06"
sType = " CONTRÔLE DE L'ÉROSION MT"
Case "07"
sType = " CONTRÔLE DE L'ÉROSION LT"
Case "08"
sType = " DRAINAGE"
Case "10"
sType = " PRODUITS DIVERS"
Case "20"
sType = " TUYAUX"
Case "30"
sType = " VÉGÉTALISATION URBAINE"
Case "Pl"
sType = " PLANS SIGNÉS ET SCELLÉS"Par contre, là où il reste le 1 %, c'est que la dernière ligne de mes données n'est pas incluse dans le résultat. Je ne suis pas arrivée à corriger le problème.
Si quelqu'un peut me dire ce qui achoppe, ce serait bien apprécié. Noter que le sku pour ce produit n'est pas numérique, mais un texte "Plans scellés et signés". Est-ce que ça peut changer quelque chose avec le code de BrunoM45 ?
Merci.