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

Anr1 · 19 Juillet 2019

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

VB:

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 · 22 Juillet 2019

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

Dranreb · 22 Juillet 2019

Bonjour.
Dans un module standard :

VB:

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 · 22 Juillet 2019

Bonjour @anouarlachiri,

Tester la macro du fichier joint.

edit : Bonjour @Dranreb

Dranreb · 22 Juillet 2019

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) :

Code:

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 · 22 Juillet 2019

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

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

Anr1

XLDnaute Occasionnel

Pièces jointes

Anr1

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

Dranreb

XLDnaute Barbatruc

Anr1

XLDnaute Occasionnel

Discussions similaires