Fusion de cellule avec macro

bonjour

étant ultra novice en macro je souhaiterai pouvoir faire une macro qui fusionne entre elles les cellules de la colonne B pour lesquels les cellules de la colonne A affiche la date=aujourdhui (sachant que les cellules date=aujourdhui se suivront dans la colonne A)

je ne sais pas si c'est clair et même si ça vous parait simple c'est compliqué pour moi

merci bcp pour votre aide !

Bonjour

Ce n'est pas une bonne idée car tu ne pourras plus trier et filtrer tes données et l’exploitation en deviendra limitée

Il est plis judicieux d'utiliser un MFC pour masquer la répétition

Merci de ta réponse 78chris

je ne souhaite pas fusionner les cellules contenant la même date (colonne A) mais les cellules de la colonne d'a coté (B), ce n'est pas dans le but de masquer la répétition du coup. J'ai bien saisie que je ne pourrais plus filtrer les données mais j'ai besoin de débloquer ce truc pour avancer merci qd même d'avoir prit le temps de répondre

RE

Tu n'auras plus que le contenu de la 1ère cellule du groupe...

bonjour 78Chris, luj,

Fusionner, c'est quelque chose à éviter, cela cause toujours des problèmes plus tard.

Sub LUJ()
     Dim Dict, i, aA
     Set Dict = CreateObject("scripting.dictionary")     'dictionaire
     Dict.comparemode = vbTextCompare        'majuscules=miniscules
     With Sheets("blad1")
          If .AutoFilterMode Then .AutoFilterMode = False
          If .FilterMode Then .ShowAllData
          Set c = .Range("A1").CurrentRegion     'votre plage
          c.Borders.LineStyle = xlContinuous     'bordures
          c.Columns(2).UnMerge               'défusionner colonne 2
          Set c2 = c.Cells(2, 2).Resize(c.Rows.Count - 1)     'plage de la 2eme colonne
          Set c1 = c.Offset(, 27 - c.Column).Resize(, 1)     'plage auxiliaire = colonne AA

          With c1                            'plage auxilaire
               .FormulaR1C1 = "=RC2"         'copy de la 2eme colonne
               aA = .Value2                  'lire les données de cette colonne
               For i = 2 To UBound(aA)       'boucler ces valeurs
                    If Not Dict.exists(aA(i, 1)) Then     'cette valeur n'est pas encore traitée
                         c1.AutoFilter 1, aA(i, 1)     'filtrer
                         Application.DisplayAlerts = False
                         c2.SpecialCells(xlVisible).Merge     'fusionner les cellules visible de la colonne 2
                         Application.DisplayAlerts = True
                         .AutoFilter 1       'désactiver filtre
                         Dict(aA(i, 1)) = vbEmpty     'ajouter au dictionaire
                    End If
               Next
               .AutoFilter
          End With
          .Columns("AA").ClearContents       'RAZ colonne auxiliaire
     End With
End Sub

Je pense que je me sui mal expliqué

merci BsAlv pour ta réponse également mais cela ne fonctionne pas dans mon cas. voir le fichier ci joint pour visualiser mon souhait (sachant que dans la colonne A date cela va bouger chaque jour)

(sachant que dans la colonne A date cela va bouger chaque jour)

cela veut dire que vous ajoutez des lignes ou que vous commencez avec des nouveaux données ? C'est pour savoir si on doit défusionner dans la macro. Pourtant une solution avec une MFC, comme mentionné par 78Chris, est plus approprié.

merci BsAlv mais cela ne fonctionne pas ou du moins par sur les bonnes cellules

re, votre problème est difficile à résoudre, surtout l'explication "cela ne fonctionne pas ou du moins par sur les bonnes cellules".

Cela veut dire que cela ne fonctionne pas du tout, pas la deuxième fois, ... . Les bonnes cellules, ce sont pourtant celles de la colonne B

Bonsoir à tous,

Essaie ceci :

J'ai supprimé la 1ère ligne du fichier initial et gardé la ligne d'en-têtes.

Option Explicit
Sub fusion()
Dim r As Range, i As Long, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    With Sheets("Blad1")
        Set r = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
        For i = 1 To r.Count
            j = 1
            Do Until r(i).Cells(j) <> Date
                j = j + 1
            Loop
            If j > 2 Then
                With .Range(r(i), r(i).Cells(j - 1)).Offset(, 1)
                    .Interior.ColorIndex = 44
                    .Merge
                End With
            End If
            i = i + j - 1
        Next i
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

klin89