Améliorer un macro pour fusionner des cellules doublons avec des conditions

[Anr1]

Bonjour tt le monde,

J'ai crée un macro qui me permets de de fusionner des cellules avec des conditions à l'aide de @mapomme que je le remercie une autre fois.

Dans le fichier joint vous trouverez un travail que j'essaye de l'effectuer mais j'arrive pas:

Les conditions de fusion:

1- Fusionner les doublons en colonne B
2- En colonne "H" : un "/" entre les valeurs des doublons
3- En colonne "J" : si en trouve voiture parmi les valeurs de doublon en colonne "K" en laisse que voiture
4- de colonne K jusqu'à "P" en additionne les valeurs


Ma macro additionne tous les valeurs à partir de colonne "K" , moi j'aimerais bien qu'elle s’arrête d'additionner au colonne "P"

ci-joint trois Feuils:
1- Feuil1:! tableau base de données
2-Result : résulta obtenu après avoir activé ma macro ( qui ne fonctionne pas comme je veux )
3- Correcte : résultat que je souhaite obtenir


Merci d'avance

Sub test()

Dim derlig&, t, d, aux, i&, j&, clef, n&, TextCompare

derlig = Cells(Rows.Count, "e").End(xlUp).Row
t = Range("a1:x" & derlig)
Set d = CreateObject("scripting.dictionary")

d.CompareMode = TextCompare
For i = 1 To derlig
  If Not d.Exists(CStr(t(i, 2))) Then
    ReDim aux(1 To UBound(t, 2))
    For j = 1 To UBound(t, 2): aux(j) = t(i, j): Next j
    d.Add CStr(t(i, 2)), aux
  Else
    aux = d(CStr(t(i, 2)))
    For j = 10 To UBound(t, 2): aux(j) = aux(j) + t(i, j): Next j
    If LCase(t(i, 9)) = "VOITURE" Then aux(9) = "VOITURE"
    d(CStr(t(i, 2))) = aux
  End If
Next i

With Worksheets("Result")
  .Activate
  For Each clef In d.Keys
    n = n + 1
    aux = d(clef)
    For j = 1 To UBound(aux): t(n, j) = aux(j): Next
  Next clef
  .UsedRange.Clear
  .Range("a1").Resize(d.Count, UBound(t, 2)) = t
  Worksheets("Feuil1").Range("a2:x2").Copy
  .Range("a2:x2").Resize(n - 1).PasteSpecial xlPasteFormats
  Application.CutCopyMode = False
  .Range("a1:x1").EntireColumn.AutoFit
End With

End Sub

 

[Anr1]

@mapomme j'aimerais bien savoir si vous pouvez m'aider à améliorer le code que vous avez crée
Merci d'avance

 

[Dranreb]

Bonjour.
Dans un module standard :

Option Explicit
Sub Résumé()
   Dim SGr2 As SsGr, SGr8 As SsGr, TRés(), L&, C&, TJn() As String, J&, Détail
   ReDim TRés(1 To 500, 1 To 24)
   For Each SGr2 In Gigogne(Feuil1.[A2:X2], 2, 8)
      Détail = SGr2.DonnéesDébut
      L = L + 1
      For C = 1 To 7: TRés(L, C) = Détail(C): Next C
      TRés(L, 9) = Détail(9)
      TRés(L, 10) = "car"
      For C = 11 To 16: TRés(L, C) = SGr2.Somme(C): Next C
      For C = 17 To 24: TRés(L, C) = Détail(C): Next C
      ReDim TJn(1 To SGr2.Count): J = 0
      For Each SGr8 In SGr2.Co
         J = J + 1
         TJn(J) = SGr8.Id
         For Each Détail In SGr8.Co
            If Détail(10) = "VOITURE" Then TRés(L, 10) = "VOITURE"
            Next Détail, SGr8
      TRés(L, 8) = Join(TJn, "/")
      Next SGr2
   Feuil2.Cells(2, 1).Resize(500, 24).Value = TRés
   End Sub

Laissez d'abord le classeur joint s'installer en complément .xlam et cochez son projet VBA GigIdx dans les références de celui de votre classeur.

 

[mapomme]

Bonjour @anouarlachiri,

Tester la macro du fichier joint.

edit : Bonjour @Dranreb

 

[Dranreb]

Une petite simplification en ayant pensé à utiliser la méthode NbSi de l'objet SsGr (type défini par le GigIdx.xlam à mettre en référence) :

Option Explicit
Sub Résumé()
   Dim SGr2 As SsGr, SGr8 As SsGr, TRés(), L&, C&, TJn() As String, J&, Détail
   ReDim TRés(1 To 500, 1 To 24)
   For Each SGr2 In Gigogne(Feuil1.[A2:X2], 2, 8)
      Détail = SGr2.DonnéesDébut
      L = L + 1
      For C = 1 To 7: TRés(L, C) = Détail(C): Next C
      TRés(L, 9) = Détail(9)
      TRés(L, 10) = IIf(SGr2.NbSi(10, "VOITURE") > 0, "VOITURE", "car")
      For C = 11 To 16: TRés(L, C) = SGr2.Somme(C): Next C
      For C = 17 To 24: TRés(L, C) = Détail(C): Next C
      ReDim TJn(1 To SGr2.Count): J = 0
      For Each SGr8 In SGr2.Co
         J = J + 1
         TJn(J) = SGr8.Id
         Next SGr8
      TRés(L, 8) = Join(TJn, "/")
      Next SGr2
   Feuil2.Cells(2, 1).Resize(500, 24).Value = TRés
   End Sub

Édition: Bonjour @mapomme

 

[Anr1]

Merci bcp @Dranreb pour ta réactivité , votre programme marche très bien

@mapomme merci bien pour l'amélioration de votre ancien programme, ton nouveau programme marche parfaitement comme je voulais.

Je vous remercie @mapomme et @Dranreb