XL 2021 Doublon à fusionner

[Bibouden1]

Bonjour à tous

Désolé de vous déranger pour peut être un problème facile à régler mais je tente ma chance.

J'ai un fichier avec une longue liste de personne ou il y a plein de doublon. Je voudrais savoir s'il est possible de faire EN UNE FOIS, UNE SEULE MANIP pour l'ensemble des doublons pour chaque nom de les fusionner en une seule cellule et centrer comme je l'ai fait dans le fichier avec Sandrine ALV (voir fichier)

Merci beaucoup

 

[job75]

Avec ces macros la fusion concerne les colonnes A (noms) et B (villes) :

Sub Fusionner()
Dim a As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Defusionner 'lance la macro
Columns(1).Insert 'insère une colonne auxiliaire
With [A1].CurrentRegion.Columns(1)
    .FormulaR1C1 = "=1/(RC[1]=OFFSET(RC[1],-1,))"
    .Value = .Value 'supprime les formules
    For Each a In .SpecialCells(xlCellTypeConstants, 1).Areas
        Union(a(0, 2), a.Columns(2)).Merge 'fusionne les noms
        Union(a(0, 3), a.Columns(3)).Merge 'fusionne les villes
    Next a
End With
Columns(1).Delete
End Sub

Sub Defusionner()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.ShowAllData 'si la feuille est filtrée
With Range("A1:B" & Cells(Rows.Count, 3).End(xlUp).Row)
    For Each c In .Cells
        If IsEmpty(c.MergeArea(1)) Then c = "µ" 'repère les cellules vides fusionnées ou non
    Next c
    .UnMerge 'défusionne
    .SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
    .Value = .Value 'supprime les formules
    .Replace "µ", "" 'efface le repérage
    .Resize(, 4).Borders.Weight = xlThin 'bordures fines
End With
End Sub

En testant sur 13200 lignes la 1ère macro s'exécute en 1,6 seconde, la boucle de repérage de la 2ème macro prend 0,25 seconde.

Edit : j'ai traité le cas où la feuille est filtrée et ajouté des bordures.

A+

 

[job75]

En testant sur 13200 lignes je constate qu'en exécutant plusieurs fois de suite la macro Fusionner la durée d'exécution augmente régulièrement.

Je ne sais pas à quoi est dû ce phénomène mais j'ai pu y remédier en exécutant la macro Defusionner puis en enregistrant et fermant le fichier.

 

[job75]

Je découvre un autre phénomène curieux.

En remplaçant le caractère de repérage "µ" par Chr(1) ça efface tout.

Par contre aucun problème si on le remplace par Chr(2), qu'a donc de spécial Chr(1) ?

 

[job75]

Bonjour Bibouden1, le forum,

La solution présentée par Dranreb - tri sur villes puis sur noms et fusion des villes puis des noms - est tout à fait intéressante.

Cependant elle est très lourde et sa durée d'exécution - 2 secondes sur 45 lignes - peut être rédhibitoire sur de grands tableaux.

En utilisant la méthode que j'ai utilisée précédemment la durée chez moi est de 0,026 seconde sur 45 lignes :

Sub Fusionner()
Dim a As Range, col%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Defusionner 'lance la macro
With Rows("1:" & Cells(Rows.Count, 3).End(xlUp).Row) 'lignes entières
    .Sort .Columns(1), xlAscending, .Columns(2), , xlAscending, Header:=xlYes 'tri sur les villes puis sur les noms
    For col = 1 To 2
        Columns(col).Insert 'insère une colonne auxiliaire entière
        With .Columns(col)
            .FormulaR1C1 = "=1/(RC[1]=OFFSET(RC[1],-1,))"
            .Value = .Value 'supprime les formules
            For Each a In .SpecialCells(xlCellTypeConstants, 1).Areas
                Union(a(0, 2), a.Columns(2)).Merge 'fusionne les villes puis les noms
            Next a
        End With
        Columns(col).Delete 'supprime la colonne auxiliaire
    Next col
End With
End Sub

Sub Defusionner()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.ShowAllData 'si la feuille est filtrée
With Range("A1:B" & Cells(Rows.Count, 3).End(xlUp).Row)
    For Each c In .Cells
        If IsEmpty(c.MergeArea(1)) Then c.MergeArea(1) = Chr(2) 'repère les cellules vides, fusionnées ou non
    Next c
    .UnMerge 'défusionne
    .SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
    .Value = .Value 'supprime les formules
    .Replace Chr(2), "" 'efface le repérage
    .Resize(, 4).Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les noms
    .Resize(, 4).Borders.Weight = xlThin 'bordures fines
End With
End Sub

@Bibouden1 que veut dire BM après le nom des villes ?

A+

 

[bsalv]

@job75 https://stackoverflow.com/questions/45602726/range-replace-is-always-true-for-chr1

 

[Dranreb]

Bonjour.
Je suis étonné, ça ne met pas 2 secondes chez moi !

 

[Dranreb]

Les durées que je relève chez moi à l'exécution de CBnClaFusio_Click :

Date et heure Durée en secondes Dernier évènement
19/12/2025 10:28:06 0,000 001 400 Démarrage session
19/12/2025 10:28:06 0,012 739 700 Début procédure
19/12/2025 10:28:06 0,038 043 100 Défusions
19/12/2025 10:28:06 0,007 325 500 Fin Boucle Gigogne
19/12/2025 10:28:06 0,007 347 900 Versement valeurs
19/12/2025 10:28:06 0,083 664 500 Fusions
19/12/2025 10:28:06 0,028 143 200 Fin procédure

 

[job75]

Bonjour Bernard,

Je suis étonné, ça ne met pas 2 secondes chez moi !

Chez moi sur le fichier du post #15 qui vient d'être téléchargé, au 1er essai la macro CBnClaFusio_Click s'exécute en 2 secondes :

Mais effectivement aux essais suivants elle s'exécute en 0,08 seconde.

Et en ajoutant Application.ScreenUpdating = False elle s'exécute en 0,01 seconde.

A+

 

[Bibouden1]

Avec ces macros la fusion concerne les colonnes A (noms) et B (villes) :

Sub Fusionner()
Dim a As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Defusionner 'lance la macro
Columns(1).Insert 'insère une colonne auxiliaire
With [A1].CurrentRegion.Columns(1)
    .FormulaR1C1 = "=1/(RC[1]=OFFSET(RC[1],-1,))"
    .Value = .Value 'supprime les formules
    For Each a In .SpecialCells(xlCellTypeConstants, 1).Areas
        Union(a(0, 2), a.Columns(2)).Merge 'fusionne les noms
        Union(a(0, 3), a.Columns(3)).Merge 'fusionne les villes
    Next a
End With
Columns(1).Delete
End Sub

Sub Defusionner()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.ShowAllData 'si la feuille est filtrée
With Range("A1:B" & Cells(Rows.Count, 3).End(xlUp).Row)
    For Each c In .Cells
        If IsEmpty(c.MergeArea(1)) Then c = "µ" 'repère les cellules vides fusionnées ou non
    Next c
    .UnMerge 'défusionne
    .SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
    .Value = .Value 'supprime les formules
    .Replace "µ", "" 'efface le repérage
    .Resize(, 4).Borders.Weight = xlThin 'bordures fines
End With
End Sub

En testant sur 13200 lignes la 1ère macro s'exécute en 1,6 seconde, la boucle de repérage de la 2ème macro prend 0,25 seconde.

Edit : j'ai traité le cas où la feuille est filtrée et ajouté des bordures.

A+

Merci beaucoup c'est parfait c'est exactement ce qu'il me faut

 

[job75]

Merci de répondre :

@Bibouden1 que veut dire BM après le nom des villes ?