XL 2019 Macro somme plusieurs lignes

[Patmarzou]

Bonjour,

J'ai des données, feuille F1 et je souhaite les extraire sur la feuille PPI. J'ai écrit une macro (pas très orthodoxe) mais elle fonctionne.
Par contre lorsque qu'il y a plusieurs lignes qui ont le même libellé et article, cela n'extrait que les montants d'une ligne.
Je souhaiterai que, dans ce cas, cela fasse la somme de ces lignes.
Suis-je clair ?
vous remerciant par avance
N'hésitez pas si vous voulez modifier ma macro pour la rendre plus fonctionnelle

 

[vgendron]

Hello ci jointe une proposition
1) avec une formule à base de sommeprod et de zones nommées (voir gestionnaire de noms)
2) avec une macro.. mais c'est juste un début de réponse.. parce que ca laisse des lignes vides.. et les colonnes ne sont pas à la place que tu souhaites

 

[Patmarzou]

Bonjour,
Je te remercie pour ta réponse, J'utilise actuellement somme prod pour récupérer les données et je voulais faire une macro car je supprime et remplace la feuille F1 souvent et je suis obligé de modifier les formules du tableau PPI ((#REF) c'est rapide mais une manip supplémentaire.
En tout cas ta macro est intéressante et je vais me pencher dessus pour en tirer quelque chose.

 

[laurent950]

Bonsoir,

En Fueille PPI (les sommes sont calculer de somme 1 à 23) comme sur Feuille F1 (Base Données)
En Feuille PPI (Repérage des doublons de la Clef (Libelles - Articles) suite au cumule des sommes
Nota : Créer sur votre Feuille excel PPI suite au fichier envoyer en Poste #1 :
- Les colonnes pour les sommes de 1 à 23 (Comme pour la Feuille F1 (Base Données)

Code :

Sub DicoDoublonSommeLaurent950()
Dim TI As Single
'    TI = Timer
' ***************************************************
'Dim d As New Scripting.Dictionary
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
    Set ShF1 = Worksheets("F1")
    Tb = ShF1.Range(ShF1.Cells(1, 7), ShF1.Cells(ShF1.Cells(65536, 7).End(xlUp).Row, 35))
Dim i, j, cpt As Double
' ***************************************************
Dim TabRes() As Variant
ReDim TabRes(1 To 26, 1 To 1)
' ***************************************************
Dim ShPP1 As Worksheet
    Set ShPPI = Worksheets("PPI")
    ShPPI.Range(ShPPI.Cells(2, 5), ShPPI.Cells(ShPPI.Cells(65536, 5).End(xlUp).Row + 1, 30)).Interior.Pattern = xlNone
    ShPPI.Range(ShPPI.Cells(2, 5), ShPPI.Cells(ShPPI.Cells(65536, 5).End(xlUp).Row + 1, 30)).ClearContents
' ***************************************************
    For i = LBound(Tb) + 1 To UBound(Tb) ' Commence à la ligne 2 (LBound(Tb) + 1)
        clef = Tb(i, 1) & Tb(i, 4)
        If d.Exists(clef) Then
            cpt = d(clef)
                For j = 7 To 29
                    TabRes(j - 3, cpt) = TabRes(j - 3, cpt) + Tb(i, j)
                Next j
                ' Option Repérage de la ligne en doublon avec (Couleur de la ligne)
                ' LIBELLE & Article (doublons) = Couleur
                    With ShPPI.Range(ShPPI.Cells(cpt + 1, 5), ShPPI.Cells(cpt + 1, 30)).Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = 2
                        .ThemeColor = xlThemeColorAccent2
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                    End With
        Else
            cpt = d.Count + 1
            d(clef) = cpt
                TabRes(1, cpt) = Tb(i, 1) ' LIBELLES
                TabRes(3, cpt) = Tb(i, 4) ' Article
                For j = 7 To 29           ' SOMME 1 à 23
                    TabRes(j - 3, cpt) = Tb(i, j)
                Next j
            ReDim Preserve TabRes(1 To 26, 1 To (cpt + 1))
        End If
    Next i
ShPPI.[E2].Resize(UBound(TabRes, 2), UBound(TabRes, 1)) = Application.Transpose(TabRes)
'MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub

Cdt

 

[Patmarzou]

Bonjour Laurent,
Je te prie de bien vouloir m'excuser pour ma réponse tardive.
La macro fonctionne très bien sur le fichier test. Dès que j'aurai un peu de temps je l'installerai et adapterai sur mon fichier.
Je te remercie pour ton excellent travail