Microsoft 365 somme et cellules fusionnées

[Nsjt]

Bonjour à tous,

J'aurai besoin de votre aide.
Je vous explique.
J'ai dans le 1er onglet de mon fichier une colonne A avec des cellules fusionnées et une colonne B. Je cherche à faire un code VBA qui me permettra de faire la somme des cellules de la colonne B pour chaque élément de la colonne A et afficher le résultat dans le 2e onglet de mon fichier.
Je vous met en PJ un exemple de ce que je souhaite faire.

Merci de votre aide.

 

[sylvanu]

Bonjour Nsjt,
Un essai en PJ avec :

Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B:B]) Is Nothing Then
         Application.ScreenUpdating = False
         DL = [B65500].End(xlUp).Row
         T = Range("A2:B" & DL) ' transfert dans array
         For i = 1 To UBound(T)
            If T(i, 1) = "" Then T(i, 1) = T(i - 1, 1)  ' on remplit le tableau pour les cellules vides ( fusionnées )
         Next i
         With Sheets("Feuil2")
            .Range("A2:B1000").ClearContents
            Ligne = 2: Somme = 0: Item = T(1, 1)
            For i = 1 To UBound(T)
                If T(i, 1) = Item Then
                    Somme = Somme + T(i, 2)
                Else
                    .Cells(Ligne, "A") = Item
                    .Cells(Ligne, "B") = Somme
                    Ligne = Ligne + 1: Somme = 0: Item = T(i, 1)
                    i = i - 1 ' on recule d'un pour le pointeur pour reprendre correctement avec le nouvel item
                End If
            Next i
            .Cells(Ligne, "A") = Item   ' on range la dernière valeur trouvée
            .Cells(Ligne, "B") = Somme
         End With
    End If
Fin:
Application.ScreenUpdating = True
End Sub

L'éxécution est automatique quand on change une valeur de la colonne B.

 

[job75]

Bonjour Nsjt, sylvanu,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim tablo, ub&, n&, i&, j&
tablo = Feuil1.[A1].CurrentRegion.Resize(, 2)
ub = UBound(tablo)
n = 1
For i = 2 To ub
    If tablo(i, 1) <> "" Then
        n = n + 1
        tablo(n, 1) = tablo(i, 1)
        tablo(n, 2) = tablo(i, 2)
        For j = i + 1 To ub
            If tablo(j, 1) <> "" Then i = j - 1: Exit For
            tablo(n, 2) = tablo(n, 2) + tablo(j, 2)
        Next j
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] '1ère cellule de destination, à adapter
    .Resize(n, 2) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[Nsjt]

Merci Sylvanu,
J'essaye avec ça en espérant m'en sortir

 

[Nsjt]

Bonjour Nsjt, sylvanu,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim tablo, ub&, n&, i&, j&
tablo = Feuil1.[A1].CurrentRegion.Resize(, 2)
ub = UBound(tablo)
n = 1
For i = 2 To ub
    If tablo(i, 1) <> "" Then
        n = n + 1
        tablo(n, 1) = tablo(i, 1)
        tablo(n, 2) = tablo(i, 2)
        For j = i + 1 To ub
            If tablo(j, 1) <> "" Then i = j - 1: Exit For
            tablo(n, 2) = tablo(n, 2) + tablo(j, 2)
        Next j
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] '1ère cellule de destination, à adapter
    .Resize(n, 2) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Elle se déclenche quand on active la feuille.

A+

Je vous remercie

 

[mapomme]

Bonjour à tous,

Pour le fun, en Excel 365, on pourrait le faire par formules sur la la feuille Feuil2 (bien fâché, on peut aussi le faire avec d'autres versions). En 365 :

Cellule E2, la formule

=FILTRE(Feuil1!A2:A99;Feuil1!A2:A99<>"")

Cellule F2 à recopier vers la bas :

=SOMME(FILTRE(Feuil1!B$2:B$999;(LIGNE(Feuil1!A$2:A$999)>=PETITE.VALEUR(SI(Feuil1!A$2:A$999<>"";LIGNE(Feuil1!A$2:A$999);"");LIGNES($1:1))) * (LIGNE(Feuil1!A$2:A$999)<SIERREUR(PETITE.VALEUR(SI(Feuil1!A$2:A$999<>"";LIGNE(Feuil1!A$2:A$999);"");LIGNES($1:2));VRAI))))