Erreur dans macro sous-totaux

[flocolombia]

Bonjour à tous,

J'ai une macro qui fonctionne depuis que je l'ai créée (il y 8 mois) et voici qu'elle ne fonctionne plus...
Je ne sais pas d'où cela vient et j'avais vraiment galéré à la faire, je ne sais pas d'où vient l'erreur.
Ce code me permettait de mettre une ligne "Sous total nomduclient" en faisant un regroupement des clients en prenant la partie avant le "/" de leur nom. Par exemple je peux avoir des clients avec les nom :
client1
client1/ab
client1 /bc
client1
et je fais un sous-total (des montants associés) pour "client1"
Le problème est que depuis aujourd'hui, la macro fait le sous-total seulement pour le dernier client de mon tableau et supprime tous les autres.

Voici le code :

Sub CommandButton1_Click()
Dim i&, j&, X&
Dim D As Object, DTmp As Object, DCode As Object
Dim TReport As Variant, TTmp As Variant, TData As Variant
Dim Code$, Plg As Range

Set D = CreateObject("Scripting.dictionary")
Set DTmp = CreateObject("Scripting.dictionary")
Set DCode = CreateObject("Scripting.dictionary")
ReDim TReport(0)

With Sheets("Feuil1")
Set Plg = .Range(.Cells(2, 1), .Cells(Rows.Count, 5).End(3))
End With

TData = Plg
For i = LBound(TData, 1) To UBound(TData, 1)
If InStr(TData(i, 1), "Sous Total ") = 0 Then
Code = Split(TData(i, 4), "/")(0)
If Not DCode.Exists(Code) Then
ReDim Preserve TReport(1 To UBound(TReport) + 1)
ReDim TTmp(2)
Set TTmp(1) = CreateObject("Scripting.dictionary")
TTmp(2) = Code
TReport(UBound(TReport)) = TTmp
DCode(Code) = UBound(TReport)
End If
Set DTmp = TReport(DCode(Code))(1)
X = DTmp.Count
ReDim TTmp(1 To UBound(TData, 2))
For j = LBound(TData, 2) To UBound(TData, 2)
TTmp(j) = CStr(TData(i, j))
Next j
TReport(DCode(Code))(0) = TReport(DCode(Code))(0) + TData(i, 5)
DTmp(X) = TTmp
Set TReport(DCode(Code))(1) = DTmp
End If
Next i
Application.ScreenUpdating = False
Plg.ClearContents
With Sheets("Feuil1")
For i = LBound(TReport) To UBound(TReport)
Set DTmp = TReport(i)(1)
.Cells(.Rows.Count, 1).End(3)(2).Resize(DTmp.Count, 5).FormulaLocal = Application.Index(DTmp.Items, , 0)
With .Cells(.Rows.Count, 1).End(3)(2)
.Value = "Sous Total " & TReport(i)(2)
.Offset(, 4) = TReport(i)(0)
End With
Next i
End With
End Sub

Merci à toute personne pouvant m'aider!

 

[flocolombia]

Re : Erreur dans macro sous-totaux

Bonsoir,

Encore une fois merci Staple1600, même si je n'ai pas tout compris aux messages!
Il y a une dernière chose sur laquelle je bloque et ensuite je devrais m'en sortir [enfin] tout seul.

Donc après les sous-totaux je souhaiterai déplacer les cellules "Total*" sur la même ligne en colonne A.
Pour l'instant j'ai procédé ainsi :
- filtrage de la colonne D lorsque le texte commence par total, j'ai donc ce code :

Sub filtertot()
'
' filtertot Macro
'

'
    Range("D1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$G$200").AutoFilter Field:=4, Criteria1:="=Total*", _
        Operator:=xlAnd
End Sub

- copie des cellules filtrer sur la colonne D :

Range("D2:D200").SpecialCells(xlCellTypeVisible).Copy

mais je n'arrive pas à intégrer le code pour les déplacer en colonne A, si je choisis A2 ça colle sur les cellules non visibles.

J'ai trouvé :

Selection.End(xlToLeft).Select

mais je n'arrive pas à l'intégrer...

 

[Staple1600]

Re : Erreur dans macro sous-totaux

Bonsoir à tous

j'ai déplacé sur une autre colonne
je te laisse donc adapter pour déplacer en colonne A

Sub DonneesSTotalparMacroIII()
Dim Derlig&, i&
Derlig = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Columns("D:D").Insert Shift:=xlToRight
Range("D1") = "CLIENTS"
Range("D2:D" & Derlig).Formula = "=TRIM(IF(ISERR(SEARCH(""/"",RC[1])),RC[1],MID(RC[1],1,SEARCH(""/"",RC[1])-1)))"
Range("A1:F" & Derlig).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(6), _
       Replace:=True, PageBreaks:=True, SummaryBelowData:=True
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
If Cells(i, "D") Like "Total*" Then
    With Cells(i, "E")
        .Value = Cells(i, "D")
        .Font.Bold = True
    End With
End If
Next
    With ActiveSheet
    .UsedRange.Value = .UsedRange.Value
    End With
Columns("D:D").Delete
End Sub

PS: Test OK sur mon PC

 

[flocolombia]

Re : Erreur dans macro sous-totaux

Merci beaucoup Staple1600, c'est parfait 🙂