Fusionner des cellules sur 34000 lignes

[iMaTh]

Bonjour à tous,

J'ai developpé une macro qui fait du fusionnement de cellules.
Le probleme etant que sur un tableau de 34 000 lignes, le fusionnement est beaucoup trop long.

Avez vous une idée pour optimiser 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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub mergeLines()
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
 
    Dim nbLigne As Long
    Dim j As Integer
    Dim k As Integer
 
    nbLigne = Range("B65536").End(xlUp).Row
 
    For i = 1 To nbLigne
 
        If Range("Z1").Offset(i, 0).Value = Range("Z1").Offset(i + 1, 0).Value Then
 
            j = i + 1
            k = i + 2
 
            Range("A" & j & ":A" & k).Merge
            Range("B" & j & ":B" & k).Merge
            Range("C" & j & ":C" & k).Merge
            Range("D" & j & ":D" & k).Merge
            Range("E" & j & ":E" & k).Merge
            Range("F" & j & ":F" & k).Merge
            Range("G" & j & ":G" & k).Merge
            Range("H" & j & ":H" & k).Merge
            Range("I" & j & ":I" & k).Merge
            Range("J" & j & ":J" & k).Merge
            Range("K" & j & ":K" & k).Merge
            Range("L" & j & ":L" & k).Merge
            Range("M" & j & ":M" & k).Merge
            Range("N" & j & ":N" & k).Merge
            Range("O" & j & ":O" & k).Merge
            Range("P" & j & ":P" & k).Merge
            Range("Q" & j & ":Q" & k).Merge
            Range("R" & j & ":R" & k).Merge
            Range("S" & j & ":S" & k).Merge
            Range("T" & j & ":T" & k).Merge
            Range("U" & j & ":U" & k).Merge
            Range("V" & j & ":V" & k).Merge
            Range("W" & j & ":W" & k).Merge
            Range("X" & j & ":X" & k).Merge
            Range("Y" & j & ":Y" & k).Merge
            Range("Z" & j & ":Z" & k).Merge
 
 
        End If
 
    Next i
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
 
End Sub

Merci beaucoup de votre aide

[neupont]

Il peut y avoir une solution qui est de fusionner des plages de plus de deux lignes quand c'est possible, mais elle ne serait vraiment efficace que si le tableau n'est pas trop morcelé et que de grandes plages sont fusionnables.
Tant que Zx est semblable à Zx+1 on se contente d'incrémenter une variable, et dès que c'est différent on fait la fusion. Je suis désolé j'ai réécrit la boucle sans les offset parce que je ne suis pas familiarisé avec cette technique et que j'aurais risqué de faire des erreurs, mais bon c'est tout à fait possible avec évidemment.

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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub mergeLines()
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
 
    Dim nbLigne As Long
    Dim j As Integer
    Dim k As Integer
 
    nbLigne = Range("B65536").End(xlUp).Row
 
    j = 1 'j = variable de début de plage    
 
    For i = 1 To nbLigne + 1       'je rajoute +1 à nbLigne pour que le code considère qu'il y a une différence entre la dernière ligne et la dernière ligne + 1, afin de fusionner la fin si besoin.
        If Range("Z" & i).Value = Range("Z" & i+1).Value Then
            'on ne fait rien sinon se contenter de laisser monter i 
        Else  
            k = i 'k = variable de fin de plage (pas vraiment utile, on pourrait utiliser i, mais ça m'évite de modifier ton code ci-dessous)
            if j <> k then 'on ne va pas fusionner des plages d'une ligne !
              Range("A" & j & ":A" & k).Merge
              Range("B" & j & ":B" & k).Merge
              Range("C" & j & ":C" & k).Merge
              Range("D" & j & ":D" & k).Merge
              Range("E" & j & ":E" & k).Merge
              Range("F" & j & ":F" & k).Merge
              Range("G" & j & ":G" & k).Merge
              Range("H" & j & ":H" & k).Merge
              Range("I" & j & ":I" & k).Merge
              Range("J" & j & ":J" & k).Merge
              Range("K" & j & ":K" & k).Merge
              Range("L" & j & ":L" & k).Merge
              Range("M" & j & ":M" & k).Merge
              Range("N" & j & ":N" & k).Merge
              Range("O" & j & ":O" & k).Merge
              Range("P" & j & ":P" & k).Merge
              Range("Q" & j & ":Q" & k).Merge
              Range("R" & j & ":R" & k).Merge
              Range("S" & j & ":S" & k).Merge
              Range("T" & j & ":T" & k).Merge
              Range("U" & j & ":U" & k).Merge
              Range("V" & j & ":V" & k).Merge
              Range("W" & j & ":W" & k).Merge
              Range("X" & j & ":X" & k).Merge
              Range("Y" & j & ":Y" & k).Merge
              Range("Z" & j & ":Z" & k).Merge
            end if
 
            j = i + 1 'on réinitialise j pour un début de nouvelle plage
        End If
 
    Next i
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
 
End Sub

Je dois avouer piteusement que je n'ai pas le temps de tester, donc ça nécessitera peut-être de petites adaptations.