[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 !
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 !
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
Bonne soirée !