XL 2010 [RESOLU] Fusion cellules horizontalement

[cp4]

Bonjour,

Je voudrai parcourir une plage et fusionner les cellules contigües non vides ayant la même valeur sur la même ligne.
Dans le fichier joint vous trouverez le résultat escompté.

En vous remerciant par avance.

Bonne journée.

 

[job75]

Bonjour cp4,

Il faut commencer les fusions par la droite :

Sub Fusion()
Dim i&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
    For i = 1 To .Rows.Count
        For j = .Columns.Count To 2 Step -1
            If .Cells(i, j) <> "" And .Cells(i, j) = .Cells(i, j - 1) Then Union(.Cells(i, j).MergeArea, .Cells(i, j - 1)).Merge
    Next j, i
End With
End Sub

A+

 

[cp4]

Bonjour cp4,

Il faut commencer les fusions par la droite :

Sub Fusion()
Dim i&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
    For i = 1 To .Rows.Count
        For j = .Columns.Count To 2 Step -1
            If .Cells(i, j) <> "" And .Cells(i, j) = .Cells(i, j - 1) Then Union(.Cells(i, j).MergeArea, .Cells(i, j - 1)).Merge
    Next j, i
End With
End Sub

A+

Bonjour @job75 ,

C'est parfait. Je t'avoue que je n'aurai jamais trouvé.

1000 Mercis.

Excellente journée.

 

[mapomme]

Bonjour @cp4 , @job75 ,

Pour le fun...
Le principal frein à la rapidité d'exécution sont les MFC sur la plage concernée.
La vitesse est significativement augmentée si on fusionne après avoir supprimé les MFC (moins 0,9 s pour 1000 lignes).
Il suffirait si nécessaire de les re-définir après l'exécution.

Dans le classeur joint, la plage compte 1 000 lignes. Le code est dans module1.

 

[cp4]

Bonjour @cp4 , @job75 ,

Pour le fun...
Le principal frein à la rapidité d'exécution sont les MFC sur la plage concernée.
La vitesse est significativement augmentée si on fusionne après avoir supprimé les MFC.
Il suffirait si nécessaire de les re-définir après l'exécution.

Dans le classeur joint, la plage compte 1 000 lignes. Le code est dans module1.

Bonjour @mapomme ,

Je te remercie beaucoup pour ton fichier. En effet, ton code est assez rapide.
Cependant, ton fichier m'a intrigué (voir le Gif ci-dessous). A l'ouverture du fichier, on est sur la feuille 1 vide.

J'active la feuille "Pour-tests", elle est vide. Mais au bout d'un instant, une plage de cellules apparaît.
J'avoue ne rien comprendre. Aurais-tu une explication? Mon portable icore5, 4Go de ram, windows7 64bits, excel 2010 32 bits. y a-t-il un rapport?
Dans le fichier pour lequel j'ai sollicité de l'aide, je n'ai pas de MFC. Les colonnes colorées, le sont par code pour repérer les dimanches.

Pourquoi tu as redimensionné en ajoutant 1 à la seconde dimension (ligne de code ci-dessous)

ReDim Preserve t(1 To UBound(t), 1 To UBound(t, 2) + 1)

Je t'avoue que je n'utilise presque jamais les Do & Co. Stp, pourrais-tu commenter ton code, ça m'aidera à mieux comprendre.

Avec mes remerciements anticipées.

 

[mapomme]

Re ,

pourrais-tu commenter ton code, ça m'aidera à mieux comprendre.

Ça vient, ça vient .

Les commentaires sont dans le code.

 

[job75]

Bonsoir mapomme,

Pour tester j'ai recopié le tableau sur 1000 lignes : ma macro post #2 s'exécute en 6,5 secondes.

Celle-ci s'exécute en 1,4 seconde :

Sub Fusion()
Dim t, i&, j%, P As Range
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
    For i = 1 To .Rows.Count
        For j = .Columns.Count To 2 Step -1
            If .Cells(i, j) <> "" And .Cells(i, j) = .Cells(i, j - 1) Then
                Set P = Union(IIf(P Is Nothing, .Cells(i, j), P), .Cells(i, j - 1))
            Else
                If Not P Is Nothing Then P.Merge: Set P = Nothing
            End If
    Next j, i
End With
MsgBox Timer - t
End Sub

A+

 

[mapomme]

@job75 ,

J'en profite pour te féliciter sincèrement à l'occasion du passage des 40 000 messages .
En cette année olympique, tu es et restes notre champion XLDien. Bravo!
Bonne soirée .

 

[job75]

Merci cher ami