XL 2016 Fusionner les cellules ayant la même date en colonne B

[Webperegrino]

Bonsoir Le Forum,
Les lignes de codes ci-après ne me fusionnent pas les cellules de la colonne B ayant la même date, cela à partir de la ligne 3.
J'ai dû rater quelque chose...
Pouvez-vous m'indiquer ce qui coince ?
Merci
Webperegrino

Dim datas, nb As Long
'on explore la colonne B à partir de la ligne 3, vers le bas
datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1).Value
nb = 1
For lg = 3 To UBound(datas)
  If nb > 3 Then
    If datas(lg, 2) = datas(lg - 1, 2) Then Cells(lg, 2).Offset(-nb).Resize(nb).Merge
  End If
Next

 

[laurent950]

Bonsoir
If nb > 3 Then est toujours égale à 1 dans votre code
Puis data est une variable tableau
datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1).Value
data ne comporte qu'une seule colonne 1
data(1 to xlignes, 1 to 1)
Il n'y a pas de colonne 2 ici datas(lg, 2)

 

[Webperegrino]

Le Forum,
Bonsoir Laurent,
Même avec ceci, je n'obtiens pas satisfaction...
Webperegrino

 

[laurent950]

Bonsoir,

Est-ce la solution ?

Private Sub CommandButton1_Click()
Dim datas() As Variant
Dim lg As Long
ReDim datas(0 To 1)
Dim Lig() As Range
ReDim Lig(0)
    Set datas(0) = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
        datas(1) = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1).Value
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim UnionRange As Range
'on explore la colonne B à partir de la ligne 3, vers le bas
For lg = LBound(datas(1), 1) To UBound(datas(1), 1)
        If Dico.Exists(datas(1)(lg, 1)) Then
            Set UnionRange = Dico.Item(datas(1)(lg, 1))
            Set UnionRange = Union(UnionRange, datas(0)(lg, 1))
            Dico.Remove datas(1)(lg, 1)
            Dico.Add datas(1)(lg, 1), UnionRange
        Else
            Set Lig(UBound(Lig)) = datas(0)(lg, 1)
            Dico.Add datas(1)(lg, 1), Lig(UBound(Lig))
            ReDim Preserve Lig(UBound(Lig) + 1)
        End If
Next lg
    ReDim Preserve Lig(UBound(Lig) - 1)
    Application.DisplayAlerts = False
    For Each k In Dico.keys
        Set Value = Dico.Item(k)
        Value.Merge
    Next k
    Application.DisplayAlerts = True
[C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

 

[Webperegrino]

Le Forum,
Bonsoir Laurent950,
Oh que oui, c'est LA solution !
Grand merci à vous pour cette aide.
Je vais mettre un mois pour savourer et surtout comprendre le fonctionnement de ces lignes : c'est parfait.
Je vois déjà plein d'applications dans mes fichiers d'autant plus qu'elles vont aussi servir à beaucoup d'entre nous, ici.
Je prendrai bien soin d'y préciser que vous en êtes l'auteur.
Encore merci, Cher Accro.
Bien cordialement,
Webperegrino, humblement impliqué

'solution de Laurent950 le 07082023 #4 ExcelDownloadForum
Dim datas() As Variant...

 

[mapomme]

Bonjour à tous,
Une autre manière ? :

Sub fusion()
Dim der&, t, ref, n&, i&, deb As Range
   With Sheets("Feuil1")
      Application.DisplayAlerts = False: Application.ScreenUpdating = False
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "b").End(xlUp).Row + 1
      Set deb = .Range("b3"): t = Range("b3:b" & der): ref = t(1, 1)
      Range("b3:b" & der - 1).Borders.LineStyle = xlContinuous: n = 1
      For i = 1 To UBound(t)
         If t(i, 1) <> ref Then
            deb.Resize(i - n).Merge
            ref = t(i, 1): n = i: Set deb = deb.Offset(1)
         End If
      Next i
      Application.DisplayAlerts = True: Application.ScreenUpdating = True
   End With
End Sub

 

[Webperegrino]

Le Forum,
Bonjour Laurent950,
Bonjour Mapomme,
2ème "Cadeau Bonux" et qui fonctionne parfaitement également.
Me voilà dans l'embarras : je dois inventer une macro qui, une fois sur deux, utilisera soit la solution de Mapomme soit la solution de Laurent950.
Merci à tous les deux pour vos belles propositions ; je vais les étudier très attentivement. ainsi je m'enrichis dans mes progrès en vba sur les applications Excel actuelles et à venir.
Grand merci à nouveau ça fait vraiment plaisir cette aide si précieuse.
J'engrange donc dans mes codes avec cette précision :

'la fusion des jours identiques
'Solution proposée par Mapomme le 08.08.2023 #6 ExcelDownloadForum (Fusionner les cellules ayant la même date en colonne B)

Webperegrino

 

[job75]

Bonjour à tous,

Une solution très simple à partir du fichier du post #3 :

Private Sub CommandButton1_Click()
Dim dat As Date
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next 'si aucune SpecialCell
With [B2].CurrentRegion
    If .Rows.Count = 1 Then Exit Sub
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri si ce n'est pas fait
    For dat = .Cells(2, 1) To .Cells(.Rows.Count, 1)
        .Replace dat, "#N/A"
        .SpecialCells(xlCellTypeConstants, 16).Merge
        .Replace "#N/A", dat
    Next
End With
End Sub

A+

 

[laurent950]

Bonsoir @Webperegrino

j'ai simplifié le code pour le même résultat
Le code en Poste #4 peut servir de réflexion
Le code du Poste #4 est épuré
Gestion des doublons avec fusion de cellule avec la méthode Union() et Obj.Merge

Avec la Boucle For Each k In Dico.keys

Private Sub CommandButton1_Click()
Dim Rng, datas As Range
    Set datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim UnionRange As Range
Dim k As Variant
For Each rgn In datas
        If Dico.Exists(rgn.Value2) Then
            Set UnionRange = Union(Dico.Item(rgn.Value2), rgn)
            Dico.Remove rgn.Value2
            Dico.Add rgn.Value2, UnionRange
        Else
            Dico.Add rgn.Value2, rgn
        End If
Next rgn
    Application.DisplayAlerts = False
    For Each k In Dico.keys
        Set UnionRange = Dico.Item(k)
            UnionRange.Merge
    Next k
    Application.DisplayAlerts = True
[C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

Sans la Boucle For Each k In Dico.keys

Private Sub CommandButton1_Click()
Dim datas As Range
    Set datas = [B3].Resize(Cells(Rows.Count, 2).End(3).Row + 1)
Dim Dico As Object
    Set Dico = CreateObject("scripting.dictionary")
Dim Rng As Range
Dim UnionRange As Range
Application.DisplayAlerts = False
    For Each rgn In datas
            If Dico.Exists(rgn.Value2) Then
                Set UnionRange = Union(Dico.Item(rgn.Value2), rgn)
                Dico.Remove rgn.Value2
                Dico.Add rgn.Value2, UnionRange
                UnionRange.Merge
            Else
                Dico.Add rgn.Value2, rgn
            End If
    Next rgn
    Application.DisplayAlerts = True
    [C1] = "CALCUL FINI !": Application.Goto [A1], Scroll:=True
End Sub

 

[Webperegrino]

Le Forum,
Re-Laurent950, Re-Mapomme,
Bonsoir Job75,
Diantre, c'est Noël pour moi aujourd'hui, avec ce que vous m'avez apporté !
Mon mémo "Codifications VBA" va prendre de l'épaisseur !
Merci beaucoup de vous être penchés sur mon projet : ces trois, quatre solutions fonctionnent avec une précision remarquable dans l'application réelle.
Bonne soirée,
Webperegrino

 

[Webperegrino]

Le Forum,
Merci Laurent950, en effet c'est bien épuré !
Webperegrino

 

[Webperegrino]

Le Forum,
Bonsoir Laurent,
Merci pour cette dernière mouture #12 (qui prend 0,4 s alors que la précédente fait le travail en seulement 0,09 s.
J'ai préalablement sorti de mon "Private Sub CommandButton2_Click()... End sub", les lignes #4, #6, #8 et #9 avec des signes " ' " en début de ligne pour les désactiver, et pour faire fonctionner #12 au cas où elles auraient allongé la durée d'exécution.
Mais ça fonctionne parfaitement aussi.
Merci beaucoup,
Toutes vos interventions ici m'on été d'un grand secours.

Quant à votre question sur mon "mémo "Codifications VBA" il s'agit d'un petit carnet dans lequel je ré-écris manuellement les lignes de codes, avec un index que je construis au fur et à mesure afin de me guider dans les conceptions futures sur Excel.
C'est ma méthode "Mac Gyver"pour évoluer en VBA...
Donc pour les lignes #1 que j'avais essayées, j'avais fureté ici et là sur le Web pour tenter de trouver une bonne solution de programmation.
J'espère avoir bien répondu à votre question.
Bonne soirée,
Webperegrino

 

[Webperegrino]

Le Forum,
Et avec ceci en fin de procédure, c'est parfait !
Webperegrino

'contours hauts et bas en colonne B
der = [D120].End(3).Row
With Range("B3:G" & der)
 .Borders(xlEdgeTop).LineStyle = xlContinuous
 .Borders(xlEdgeBottom).LineStyle = xlContinuous
 .Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With

 

[job75]

Bonsoir Laurent,
Merci pour cette dernière mouture #12 (qui prend 0,4 s alors que la précédente fait le travail en seulement 0,09 s.

Au post #8 l'exécution se fait en 0,02 s ou 0,03 s chez moi.

 

[Webperegrino]

Le Forum,
Bonjour Job75,
Ouh là ! la macro, ici a réagi à votre #14 quand je l'ai remise à travailler une deuxième fois.
Voilà qu'elle s'exécute maintenant à 0,188 s !
Cela doit être parce qu'elle a reconnu son Maître réagir en post #14 et veut être conforme à votre dernière remarque... LOL comme on dit.
Il n'empêche que ces quelques lignes réalisent le travail en un éclair ! C'est génial.

Bien que ce qui suit n'aie rien à voir avec l'objet premier de ma démarche, je me permets de l'inclure pour le cas où il y aurait une meilleur codification ; je comprendrais de ne pas recevoir de réponse. Mais il est aussi possible que cela intéresse d'autres lecteurs.

Cells(lgd, 5) = (Len(PAN.Cells(lg, col)) - Len(Replace(PAN.Cells(lg, col), "ZZ", ""))) / 2

Pouvez-vous me confirmer que cette approche est correcte ? Si j'avais mis 'ZZZ' aurait-il fallu diviser par trois dans la formule VBA ? Pour le moment elle me convient car elle donne une bonne réponse sélective.
Cette ligne consiste à indiquer combien de fois il est rencontré ZZ, dans chaque cellule rencontrée dans un pavé [G28:AZ37]. il y est inscrit soit un soit jusqu'à six prénoms avec des retours à la ligne chr(10) dans les lignes de codes qui fonctionnent bien. ZZ désigne à chaque fois un prénom non encore attribué de ma liste de prénoms.

J'ai été obligé de doubler le 'Z' en ZZ car sinon il prenait en compte des prénoms du type Élizabeth, par exemple, et cela faussait les résultats.

J'ai essayé aussi une belle formule secrète de Monsieur BOISGONTIER mais ne fonctionne pas ici dans une cellule pour laquelle un prénom est placé dans la cellule G7 pour l'interrogation.

=SOMME(--(NB.SI(DECALER($G$7;{0};{6.7.8.9.10.11.12.13.14.15.16.17.18.19.20.21.22.23.24.25.26.27.28.29.30.31.32.33.34.35.36.37.38.39.40.41.42.43.44.45.46.47.48.49.50.51.52}*1;1;1);$BB$7)>0))

Webperegrino