XL 2010 [RESOLU] Fusion cellules horizontalement

cp4 · 18 Mars 2024

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 · 18 Mars 2024

Bonjour cp4,

Il faut commencer les fusions par la droite :

VB:

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+

job75 · 18 Mars 2024

Bonjour cp4,

Il faut commencer les fusions par la droite :

VB:

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 · 18 Mars 2024

job75 à dit:

Bonjour cp4,

Il faut commencer les fusions par la droite :

VB:

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 · 18 Mars 2024

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 · 18 Mars 2024

mapomme à dit:
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)

VB:

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 · 18 Mars 2024

Re ,

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

Ça vient, ça vient .

Les commentaires sont dans le code.

job75 · 18 Mars 2024

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 :

VB:

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 · 18 Mars 2024

@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 · 18 Mars 2024

Merci cher ami

XL 2010 [RESOLU] Fusion cellules horizontalement

cp4

XLDnaute Barbatruc

Pièces jointes

job75

job75

XLDnaute Barbatruc

Pièces jointes

cp4

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

cp4

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires