Macro VBA tableau à lignes variables
Bonjour,
Dans le cadre de mes travaux et d'optimisation de temps, j'essaye de mettre au point une macro permettant de créer des sous-totaux et généré des lignes en plus dans le tableau. J'ai réussi à coder les lignes permettant de créer les sous-totaux mais je bloque sur les lignes que je veux générer.
Je vous ai mis ci-joint un fichier word expliquant tout le processus ainsi que le code de ma macro et un fichier excel avec le tableau.
Merci par avance de votre aide
Petit up avant que mon message tombe dans les abysses du forum
Bonsoir gloub658,
Essaie ceci :
Restitution en feuil1 préalablement créée
Option Explicit
Sub test()
Dim dico As Object, i As Long, e, n As Long, x As Double, rng As Range
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("CSA")
With .Cells(1).CurrentRegion
For i = 2 To .Rows.Count
If Not dico.exists(.Cells(i, 4).Value) Then
If dico.Count = 0 Then
Set dico(.Cells(i, 4).Value) = _
Union(.Rows(1), .Rows(i))
Else
Set dico(.Cells(i, 4).Value) = .Rows(i)
End If
Else
Set dico(.Cells(i, 4).Value) = _
Union(dico(.Cells(i, 4).Value), .Rows(i))
End If
Next
End With
End With
Application.ScreenUpdating = False
With Sheets("Feuil1")
.Cells.Clear
For Each e In dico
n = n + 1
dico(e).Copy .Cells(n, 1)
With .Cells(n, 1).CurrentRegion
With .Offset(.Rows.Count).Resize(1)
dico(e).Rows(dico(e).Rows.Count).Copy .Cells(1)
With .Columns("a:o")
.ClearContents
.Interior.ColorIndex = 6
.Value = _
Array(dico(e).Cells(dico(e).Rows.Count, 1).Value, dico(e).Cells(dico(e).Rows.Count, 2).Value, _
dico(e).Cells(dico(e).Rows.Count, 3).Value, dico(e).Cells(dico(e).Rows.Count, 4).Value, _
dico(e).Cells(dico(e).Rows.Count, 5).Value & e, "CORPA00", "MOVM0000NI", "VARP", _
dico(e).Cells(dico(e).Rows.Count, 9).Value, dico(e).Cells(dico(e).Rows.Count, 10).Value, _
dico(e).Cells(dico(e).Rows.Count, 11).Value, dico(e).Cells(dico(e).Rows.Count, 12).Value, _
"C", "=subtotal(9,r" & n & "c:r[-1]c)", "=subtotal(9,r" & n & "c:r[-1]c)")
End With
If rng Is Nothing Then
Set rng = .Rows(1)
x = .Cells(.Cells.Count).Value
Else
Set rng = Union(rng, .Rows(1))
x = x + .Cells(.Cells.Count).Value
End If
End With
End With
n = n + dico(e).Rows.Count
Next
rng.Copy .Cells(n + 1, 1)
.Rows(n).EntireRow.Delete
With .Cells(n, 1).Resize(dico.Count - 1, rng.Columns.Count)
.Columns("a").Value = dico("EUR").Cells(dico("EUR").Rows.Count, 1).Value
.Columns("d").Value = dico("EUR").Cells(dico("EUR").Rows.Count, 4).Value
.Columns("m").Value = "D": .Columns("n").Value = .Columns("o").Value
With .Offset(.Rows.Count).Resize(1)
.Interior.ColorIndex = 22
.Cells(5).Value = "38890TRAT1": .Cells(6).Value = "BQCASA0001"
.Cells(7).Value = "00000000NI": .Cells(8).Value = "0"
.Cells(14).Value = x: .Cells(15).Value = x
End With
End With
End With
Set rng = Nothing: Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Re gloub658,
Les modifications s'opèrent directement sur la feuille concernée
A tester sur une copie de tes données au cas où :
Option Explicit
Sub test()
Dim r As Range, rng As Range, x As Double, derLig As Long, lig As Long
Application.ScreenUpdating = False
With Sheets("CSA")
.Columns(1).Insert
With .Range("e3", .Range("e" & .Rows.Count).End(xlUp)).Offset(, -4)
.Formula = "=if(e3<>e2,if(a2=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
.SpecialCells(2, 1).EntireRow.Insert
.SpecialCells(2, 2).EntireRow.Insert
On Error GoTo 0
End With
.Columns(1).Delete
For Each r In .Columns("d").SpecialCells(2).Areas
With r
.Offset(.Rows.Count - 1, -3).Resize(1, 15).Copy .Offset(.Rows.Count, -3).Resize(1, 15)
With .Offset(.Rows.Count, -3).Resize(1, 15)
.Cells(5).Value = .Cells(5).Offset(-1).Value & .Cells(4).Value
.Cells(6).Value = "CORPA00"
.Cells(7).Value = "MOVM0000NI"
.Cells(8).Value = "VARP"
.Cells(13).Value = "C"
.Cells(14).Formula = "=subtotal(9," & r.Offset(, 10).Address & ")"
.Cells(15).Formula = "=subtotal(9," & r.Offset(, 11).Address & ")"
End With
If rng Is Nothing Then
Set rng = .Offset(.Rows.Count, -3).Resize(1, 15)
x = .Offset(.Rows.Count, -3).Resize(1, 15).Cells(15).Value
Else
Set rng = Union(rng, .Offset(.Rows.Count, -3).Resize(1, 15))
x = x + .Offset(.Rows.Count, -3).Resize(1, 15).Cells(15).Value
End If
End With
Next
derLig = .Cells(.Rows.Count, 1).End(xlUp).Row
rng.Copy .Cells(derLig + 1, 1).Resize(, rng.Columns.Count)
For lig = derLig + 1 To derLig + rng.Areas.Count - 1
.Cells(lig, 1).Value = .Cells(derLig + rng.Areas.Count, 1).Value
.Cells(lig, 4).Value = .Cells(derLig + rng.Areas.Count, 4).Value
.Cells(lig, 13).Value = "D"
.Cells(lig, 14).Value = .Cells(lig, 15).Value
Next
.Cells(derLig + rng.Areas.Count, 5).Value = "38890TRAT1"
.Cells(derLig + rng.Areas.Count, 6).Value = "BQCASA0001"
.Cells(derLig + rng.Areas.Count, 7).Value = "00000000NI"
.Cells(derLig + rng.Areas.Count, 8).Value = 0
.Cells(derLig + rng.Areas.Count, 14).Value = x
.Cells(derLig + rng.Areas.Count, 15).Value = x
.Rows(derLig).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Subklin89
Bonjour Klin89,
Ta macro marche à merveille.
Merci infiniment
Bonjour,
J'aurai besoin de votre aide pour améliorer la magnifique macro de Klin89 :
Je vous ai un mis un tableau exemple, avec le modèle de base dans la feuille "CSA" et ce que la macro doit accomplir dans la feuille "finale".
En fait, la 1ère macro calcul le sous-total pour chaque devise si l'entité est "A" sauf l'EUR. Lorque l'entité est "W", la macro doit juste insérer une copie de la ligne après chaque ligne en remplaçant D par C, peu importe la devise. Je vous ai surligné en orange les lignes avec l'entité W dans la feuille "CSA", la macro doit générer les lignes en bleu dans la feuille "finale".
Merci par avance de votre aide
gloub658