XL 2010 [RESOLU] Fusion cellules horizontalement

  • Initiateur de la discussion Initiateur de la discussion cp4
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

cp4

XLDnaute Barbatruc
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.
 

Pièces jointes

Solution
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 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+
 

Pièces jointes

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.
 
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.
 

Pièces jointes

Dernière édition:
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.
Mapomme.gif

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.
 
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+
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
9
Affichages
144
Retour