Fusionner un nombre de cellules variable

Version imprimable

1 pièce(s) jointe(s)

Bonjour,

Débutant en vba, je bloque sur un une partie de mon code qui fonctionne mal et qui est surement améliorable. Pour mieux comprendre mon problème, vous référer au fichier excel joint.

Je dois fusionner toutes les cellules qui commencent par "SG" avec les cellules vides qui suivent. Selon les "SG", le nombre de cellule à fusionner est aléatoire.

Ma boucle fonctionne, mais met beaucoup de temps à s'executer (elle tourne assez longtemps dans chaque groupe de cellules fusionnées) , j'ai surement raté quelque chose.

Voici mon code:
Code:

1 2 3 4 5 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 Sub Macro1() lastRow = ActiveSheet.Cells(65536, 1).End(xlUp).Row For i = 1 To lastRow If Cells(i, 1).Value Like "SG*" Then Range(Cells(i, 1), Cells(i, 1).End(xlDown).Offset(-1, 0)).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Merge With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Next End Sub
Merci de votre aide !!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Fusion()
Dim c As Range
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    For Each c In .Range("A:A").SpecialCells(xlCellTypeConstants)
        If Left(c.Value, 2) = "SG" Then
            With .Range(c, c.End(xlDown).Offset(-1))
                .Merge
                .VerticalAlignment = xlTop
            End With
        End If
    Next c
End With
End Sub

Code n'est pas général et fonctionne sous les 2 conditions
- Colonne A non vide
- Au moins une cellule vide entre 2 valeurs SG-xx et Total SG-xx

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub test()
 
Dim i As Integer
 
Dim premligneSG As Long
Dim dernligneSG As Long
 
Dim dernligne As Long
 
 
dernligne = 1
 
While Cells(dernligne, 1) <> "Total général"
    dernligne = dernligne + 1
Wend
 
For i = 1 To dernligne
    If Cells(i, 1) Like "SG*" Then
        premligneSG = i
        dernligneSG = premligneSG
        While Cells(dernligneSG + 1, 1) = ""
            dernligneSG = dernligneSG + 1
        Wend
        Range(Cells(premligneSG, 1), Cells(dernligneSG, 1)).MergeCells = True
        i = dernligneSG
    End If
Next i
 
End Sub

12/06/2013, 11h57
Bib00

Ca marche très bien :)
Merci beaucoup !!