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

anouarlachiri

XLDnaute Junior
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
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
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.
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
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
 
Dernière édition:

Discussions similaires


Haut Bas