Regrouper ligne si valeurs identiques de 2 colonnes

Bonjour,

voici mon code qui fonctionne très bien pour regrouper/fusionner les valeurs identiques de la colonne 5 (colCrit1 = 5) et somme de la colonne 12 (colOper = 12).

' regrouper avec cumul
Set f = Sheets("vente-2020")
Set f2 = Sheets("vente-2020")
Tbl = f.Range("A2:W" & f.[A65000].End(xlUp).Row).Value
' valeur de référence

colCrit1 = 5

' cumul et somme de la colonne 12

colOper = 12

'code

Set d1 = CreateObject("Scripting.Dictionary")
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To UBound(Tbl, 2))
For i = LBound(Tbl) To UBound(Tbl)
temp = Tbl(i, colCrit1)
If Not d1.exists(temp) Then
d1(temp) = d1.Count + 1: lig = d1(temp)
For k = 1 To UBound(Tbl, 2): TblRes(lig, k) = Tbl(i, k): Next k
Else
lig = d1(temp): TblRes(lig, colOper) = TblRes(lig, colOper) + Tbl(i, colOper)
End If
Next i
Sheets("vente-2020").[A2:W65000].ClearContents
f2.[A2].Resize(d1.Count, UBound(TblRes, 2)) = TblRes

Je voudrais faire évoluer le code et ajouter une deuxième valeur de référence qui signifierai : si les valeurs de la colonne 5 et 6 sont similaires alors j’exécute le code.

Votre aide me serai bien utile!

Merci d'avance.

Bonjour

si j'ai compris, à essayer :

.../...
For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, colCrit1) =  Tbl(i, colCrit1+1) Then ' si dans ligne 5 colonne 5 =colonne 6
        temp = Tbl(i, colCrit1)
        If Not d1.exists(temp) Then
            d1(temp) = d1.Count + 1: lig = d1(temp)
            For k = 1 To UBound(Tbl, 2): TblRes(lig, k) = Tbl(i, k): Next k
        Else
            lig = d1(temp): TblRes(lig, colOper) = TblRes(lig, colOper) + Tbl(i, colOper)
        End If
    End If
Next i
.../...

A+

Bonjour,

Merci Algoplus pour votre réponse ce n'est pas tout a fait ça.

J'ai posté un exemple simplifié en pièce jointe : si valeur unique en A et B cumul en C avec peut être colCrit2 = 2 ?

Je recherche à n'avoir aucun doublon en tenant compte de deux colonnes et cumul en C

' regrouper avec cumul
Set f = Sheets("feuil1")
Set f2 = Sheets("feuil1")
Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
' valeur de référence

colCrit1 = 1

' cumul et somme de la colonne 3

colOper = 3

'code

Set d1 = CreateObject("Scripting.Dictionary")
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To UBound(Tbl, 2))
For i = LBound(Tbl) To UBound(Tbl)
temp = Tbl(i, colCrit1)
If Not d1.exists(temp) Then
d1(temp) = d1.Count + 1: lig = d1(temp)
For k = 1 To UBound(Tbl, 2): TblRes(lig, k) = Tbl(i, k): Next k
Else
lig = d1(temp): TblRes(lig, colOper) = TblRes(lig, colOper) + Tbl(i, colOper)
End If
Next i
Sheets("Feuil1").[A2:C65000].ClearContents
f2.[A2].Resize(d1.Count, UBound(TblRes, 2)) = TblRes

Essayer puis adapter ce code basé sur le classeur exemple:

Private Sub bbto()
Dim f As Worksheet, dico As Object, i As Long, k As Long, TblRes(), Temp
Set f = Sheets("feuil1")
'Set f2 = Sheets("feuil1")
Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
' valeur de référence
colCrit1 = 1
colCrit2 = 2
' cumul et somme de la colonne 3
coloper = 3

'code

Set dico = CreateObject("Scripting.Dictionary")

For i = LBound(Tbl) To UBound(Tbl)
    crit1 = Tbl(i, colCrit1)
    crit2 = Tbl(i, colCrit2)
    dico(crit1 & "|" & crit2) = dico(crit1 & "|" & crit2) + Tbl(i, coloper)
Next
ReDim TblRes(1 To dico.Count, 1 To UBound(Tbl, 2))
For Each clé In dico.keys
    k = k + 1
    Temp = Split(clé, "|")
    TblRes(k, 1) = Temp(0)
    TblRes(k, 2) = Temp(1)
    TblRes(k, 3) = dico(clé)
Next

f.[A2:C65000].ClearContents
f.[H2].Resize(dico.Count, UBound(TblRes, 2)) = TblRes

End Sub

A+

Votre code fonctionne mais conserve uniquement les 3 colonnes colcrit1, colcrit2 et colOper1.

J'ai besoin de conserver l'intégralité des colonnes de A à W avec colCrit1 = 1 colCrit2 = 5 et colOper1 à 5.

Voici mon code initial auquel je voudrais ajouter colCrit2.

' regrouper selon colcrit1 et colcrit2 avec cumul des colonnes coloper1 à 5
Set f = Sheets("feuil1")
'Tbl = f.Range("A2:W" & f.[A65000].End(xlUp).Row).Value
colCrit1 = 1
'colCrit2 = 5
colOper1 = 12
colOper2 = 13
colOper3 = 14
colOper4 = 15
colOper5 = 16
Set d1 = CreateObject("Scripting.Dictionary")
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To UBound(Tbl, 2))
For i = LBound(Tbl) To UBound(Tbl)
Temp = Tbl(i, colCrit1)
If Not d1.exists(Temp) Then
d1(Temp) = d1.Count + 1: lig = d1(Temp)
For k = 1 To UBound(Tbl, 2): TblRes(lig, k) = Tbl(i, k): Next k
Else
lig = d1(Temp): TblRes(lig, colOper1 ) = TblRes(lig, colOper1) + Tbl(i, colOper1)
lig = d1(Temp): TblRes(lig, colOper2) = TblRes(lig, colOper2) + Tbl(i, colOper2)
lig = d1(Temp): TblRes(lig, colOper3) = TblRes(lig, colOper3) + Tbl(i, colOper3)
lig = d1(Temp): TblRes(lig, colOper4) = TblRes(lig, colOper4) + Tbl(i, colOper4)
lig = d1(Temp): TblRes(lig, colOper5) = TblRes(lig, colOper5) + Tbl(i, colOper5)
End If
Next i
Sheets("feuil1").[A2:W65000].ClearContents
f2.[A2].Resize(d1.Count, UBound(TblRes, 2)) = TblRes