[VBA] - Somme de valeurs uniques, selon critère dans une colonne

Bonjour,

Pour faire la somme de surfaces, selon certains critères, j'utilise actuellement 3 macros qui vont : classer les données, faire la somme selon les critères, remplir les cellules vides.

Savez-vous s'il existe une solution plus simple, sans classer, pour faire la même chose ? J'y arrive en utilisant un dictionnaire, quand je connais à l'avance le contenu de mes cellules. Peut-être peut-on faire avec un dictionnaire ?

Pour être clair dans ce que je veux faire :

> Faire la somme des valeurs contenues dans la colonne "C", pour chaque information identique contenue dans la colonne "B", uniquement si la valeur de la colonne "C" n'est pas identique avec une valeur déjà utilisée pour la somme. (en gros, faire la somme de valeurs uniques, pour chaque info différente contenu dans la colonne B).

> Puis renseigner le total, pour chaque ligne concernée.

Je joins un document, qui fait ce que je veux faire, mais en passant par 3 étapes, dont une qui consiste à classer (et dont j'aimerais me passer, car la macro qui classe semble être celle qui prend le plus de temps ; ce temps peut varier selon les tailles de tableaux et parce que je me retrouve à classer x fois dans la procédure)

Je vous remercie de votre attention,

Bonne journée !

15test-dict-sum.xlsm (27.95 Ko)

Bonsoir,

Premiers tests pour essayer de me passer des macros dont je parles, j'ai mis de côté les sommes, et ai simplement ajouté des éléments à la suite en passant par des dictionnaires et des variables tableau.

Le résultat est bon, je vais donc tester avec les sommes.

Voici le code en question (un peu violent à mettre au point... c'est le genre de macro qui à tendance à m'inquiéter pour la suite) :

Dim a&, e&, y&, aa As Variant, dict1 As Object, dict2 As Object, dict3 As Object, tab1() As String, _
tab2() As String, sond$, gepa$, save1$, save2$, wr1$, wr2$
Set dict1 = CreateObject("scripting.dictionary"): Set dict2 = CreateObject("scripting.dictionary")
Set dict3 = CreateObject("scripting.dictionary")

With ActiveSheet
aa = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
sond$ = "": gepa = "": y = 1

ReDim tab1(1 To 2, 1 To y): ReDim tab2(1 To 2, 1 To y)
    For a = 2 To UBound(aa)
        If Not dict1.exists(aa(a, nzh) & aa(a, ids)) And aa(a, ids) <> "" Then
            If Not dict2.exists(aa(a, nzh)) Then
            sond = ""
                If sond = "" Then sond = aa(a, ids) Else sond = sond & ", " & aa(a, ids)
                    ReDim Preserve tab1(1 To 2, 1 To y): ReDim Preserve tab2(1 To 2, 1 To y)
                    tab1(1, y) = aa(a, nzh): tab1(2, y) = sond ': y = y + 1
                dict1(aa(a, nzh) & aa(a, ids)) = "": dict2(aa(a, nzh)) = ""
            Else
                cib = in_array(tab1, aa(a, nzh)): cib = t
                If sond = "" Then sond = tab1(2, cib) Else sond = tab1(2, cib) & ", " & aa(a, ids) 
                    ReDim Preserve tab1(1 To 2, 1 To y): ReDim Preserve tab2(1 To 2, 1 To y)
                    tab1(1, cib) = aa(a, nzh): tab1(2, cib) = sond
                dict1(aa(a, nzh) & aa(a, ids)) = "": dict2(aa(a, nzh)) = ""
            End If
        End If
        If Not dict1.exists(aa(a, nzh) & aa(a, gep)) And aa(a, gep) <> "" Then
            If Not dict3.exists(aa(a, nzh)) Then
            gepa = ""
                If gepa = "" Then gepa = aa(a, gep) Else gepa = gepa & ", " & aa(a, gep)
                    ReDim Preserve tab2(1 To 2, 1 To y): ReDim Preserve tab2(1 To 2, 1 To y)
                    tab2(1, y) = aa(a, nzh): tab2(2, y) = gepa: y = y + 1
                dict1(aa(a, nzh) & aa(a, gep)) = "": dict3(aa(a, nzh)) = ""
            Else
                cib = in_array(tab2, aa(a, nzh)): cib = t
                If gepa = "" Then gepa = tab2(2, cib) Else gepa = tab2(2, cib) & ", " & aa(a, gep)
                    ReDim Preserve tab2(1 To 2, 1 To y): ReDim Preserve tab2(1 To 2, 1 To y)
                    tab2(1, cib) = aa(a, nzh): tab2(2, cib) = gepa
                dict1(aa(a, nzh) & aa(a, gep)) = "": dict3(aa(a, nzh)) = ""
            End If
        End If
    Next a

save1 = "": save2 = ""
    For a = 2 To UBound(aa)
        If save1 <> "" And aa(a, nzh) = save1 Then
            .Cells(a, ids) = wr1
        Else
            For e = UBound(tab1) To 1 Step -1
                If tab1(1, e) = aa(a, nzh) Then .Cells(a, ids) = tab1(2, e): save1 = aa(a, nzh): wr1 = tab1(2, e): Exit For
            Next e
        End If
        If save2 <> "" And aa(a, nzh) = save2 Then
            .Cells(a, gep) = wr2
        Else
            For e = UBound(tab1) To 1 Step -1
                If tab2(1, e) = aa(a, nzh) Then .Cells(a, gep) = tab2(2, e): save2 = aa(a, nzh): wr2 = tab2(2, e): Exit For
            Next e
        End If
    Next a
End With
Function in_array(tabl, rech) 'https://www.excel-pratique.com/fr/astuces_vba/recherche-tableau-array
Dim i%
t = 0
    On Error Resume Next
    For i = LBound(tabl) To UBound(tabl, 2) 'Identifier la localisation de chaque colonne
        If tabl(1, i) = rech Then t = i:  Exit For
    Next
End Function

A plus tard !

Bonjour,

Plus simplement, tu ne peux pas travailler sur une copie où tu supprimes les doublons sur LIB_PHYSIO & Nom_ZH ?

image

eric

Bonsoir,

En effet, présenté comme ça, mon tableau incite à supprimer les doublons.

Mais, dans mon tableau initial, il y a 93 colonnes, avec des informations qui seraient perdues si une ligne venait à être supprimée. J'ai simplifié le tableau pour le rendre plus compréhensible.

C'est pour éviter de supprimer des lignes que je renseigne la même valeur sur toutes les lignes lorsque j'ai un résultat à indiquer.

Edit : Ah mais en fait, peut-être qu'il est effectivement possible de faire une copie, pour supprimer les doublons, faire une macro pour les sommes qui soit plus simple et rapatrier les résultats dans la feuille initiale.

J'ai finalement réussi à faire fonctionner ma macro pour les sommes.

Je joins le document, dans lequel il y a les 2 méthodes.

Macro :

Option Explicit
Public nzh As Byte, surf As Byte, cib As Byte, t&

Public Sub macro4()
Dim a&, e&, y&, aa As Variant, dict1 As Object, compt!, save$, wr!, dict2 As Object, tab1() As String, _
tab2() As String
Set dict1 = CreateObject("scripting.dictionary"): Set dict2 = CreateObject("scripting.dictionary")

With ActiveSheet
nzh = 0: On Error Resume Next: nzh = .Range("1:1").Find("Nom_ZH", LookIn:=xlValues, Lookat:=xlWhole).Column
surf = 0: On Error Resume Next: surf = .Range("1:1").Find("SURF_HAB_maj", LookIn:=xlValues, Lookat:=xlWhole).Column

aa = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
compt = 0: y = 1

ReDim tab1(1 To 2, 1 To y)
    For a = 2 To UBound(aa)
        If Not dict1.exists(aa(a, nzh) & aa(a, surf)) Then
            If Not dict2.exists(aa(a, nzh)) Then
            compt = 0
                If compt = 0 Then compt = aa(a, surf) Else compt = compt + aa(a, surf)
                    ReDim Preserve tab1(1 To 2, 1 To y)
                    tab1(1, y) = aa(a, nzh): tab1(2, y) = compt: y = y + 1
                dict1(aa(a, nzh) & aa(a, surf)) = "": dict2(aa(a, nzh)) = ""
            Else
                cib = in_array(tab1, aa(a, nzh)): cib = t
                If compt = 0 Then compt = tab1(2, cib) Else compt = tab1(2, cib) + aa(a, surf)
                    ReDim Preserve tab1(1 To 2, 1 To y)
                    tab1(1, cib) = aa(a, nzh): tab1(2, cib) = compt
                dict1(aa(a, nzh) & aa(a, surf)) = "": dict2(aa(a, nzh)) = ""
            End If
        End If
    Next a

save = "": wr = 0
    For a = 2 To UBound(aa)
            If save <> "" And aa(a, nzh) = save Then
                .Cells(a, UBound(aa, 2) + 1) = wr
            Else
                For e = UBound(tab1, 2) - 1 To 1 Step -1
                    If tab1(1, e) = aa(a, nzh) Then .Cells(a, UBound(aa, 2) + 1) = CDbl(tab1(2, e)): save = aa(a, nzh): wr = CDbl(tab1(2, e)): Exit For
                Next e
            End If
    Next a
.Cells(1, UBound(aa, 2) + 1) = "SURF_pedo_maj"
End With
End Sub
Function in_array(tabl, rech) 'https://www.excel-pratique.com/fr/astuces_vba/recherche-tableau-array
Dim i%
t = 0
    On Error Resume Next
    For i = LBound(tabl) To UBound(tabl, 2) 'Identifier la localisation de chaque colonne
        If tabl(1, i) = rech Then t = i:  Exit For
    Next
End Function
18test-dict-sum.xlsm (32.67 Ko)

Bonne soirée !

Rechercher des sujets similaires à "vba somme valeurs uniques critere colonne"