Optimiser une macro

**mikadoo57** · 19/03/2013, 14h13

Bonjour,
je voudrai optimiser une macro assez chronophage mais sans en avoir les compétences, donc je me retourne vers vous.
Cette macro (un grand merci à AVSInfoGest

) est chargée de copier et fusionner dans une feuille de synthèse les lignes non vides de 8 tableaux (de 1200 lignes max) situés sur 8 feuilles du classeur. Le code est le suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CommandButton2_Click()
 
    Dim Lig1 As Integer         'Lig1 est un entier
    Dim Col1 As Integer         'Col1 est un entier
    Dim MaFeuille As Worksheet  'MaFeuille est une feuille
    Dim Ligne As Integer        'Ligne est un entier
 
    Application.ScreenUpdating = False
    Feuil1.Range("A3:N6002").Cells.Clear
 
    Lig1 = 3
        For Each MaFeuille In Sheets  
        If MaFeuille.Name Like "Act*" Then 'les feuilles concernées portent toutes un nom commançant par "Activités de..."
            With MaFeuille
                 For Ligne = 3 To .UsedRange.Row + .UsedRange.Rows.Count 'pour info, en mettant ...=3 To 1200, le temps d'exécution est le même
                   If .Cells(Ligne, 2) <> "" Then
                         For Col1 = 1 To 14 'chaque tableau à 14 colonnes
                             Feuil1.Cells(Lig1, Col1).Value = .Cells(Ligne, Col1).Value
                         Next
                         Lig1 = Lig1 + 1
                     End If
                 Next
            End With
          End If
    Next
 
    Application.ScreenUpdating = True 
End Sub

j'ai l'impression que la recherche ligne par ligne en est la raison et si quelqu'un à une solution, je suis preneur.
Merci

**Daniel.C** · 19/03/2013, 15h12

Bonjour,

Non testé; si , comme probable, ça plante, pourras-tu mettre un classeur réduit en PJ ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CommandButton2_Click()
 
    Dim Lig1 As Integer         'Lig1 est un entier
    Dim Col1 As Integer         'Col1 est un entier
    Dim MaFeuille As Worksheet  'MaFeuille est une feuille
    Dim Ligne As Integer        'Ligne est un entier
    Dim Result(6000, 14)
    Dim Tabl
 
    Application.ScreenUpdating = False
    Feuil1.Range("A3:N6002").Cells.Clear
    lig = 1
        For Each MaFeuille In Sheets
        If MaFeuille.Name Like "Act*" Then 'les feuilles concernées portent toutes un nom commançant par "Activités de..."
            With MaFeuille
                 Tabl = .Range(.Cells(1, 1), .Cells(.Find("*", , , , xlByRows, xlPrevious).Row, 14))
                 For Ligne = 3 To UBound(Tabl) 'pour info, en mettant ...=3 To 1200, le temps d'exécution est le même
                   If Tabl(Ligne, 2) <> "" Then
                         For Col1 = 1 To 14 'chaque tableau à 14 colonnes
                             Result(Lig1, Col1).Value = Tabl(Ligne, Col1).Value
                         Next
                         Lig1 = Lig1 + 1
                     End If
                 Next
            End With
          End If
    Next
    Feuil1.[A3].Resize(6000, 14) = Result
    Application.ScreenUpdating = True
End Sub

**mikadoo57** · 19/03/2013, 15h40

Je viens de tester.
j'ai laissé la ligne 11 de mon code tel quel car tu écris lig=1 mais lig n'est pas défini et ne se retrouve pas dans le code.
Le code bute le mot 'Find' de la ligne 11 (membre de méthode ou de données introuvable). Je ne suis pas trop surpris car le mot Find n'est pas proposé par l'intellisense lors de la frappe.

**Daniel.C** · 19/03/2013, 16h04

peux-tu mettre un classeur exemple en PJ ?

**mikadoo57** · 19/03/2013, 16h14

Pas possible depuis le taf car Intranet protégé et sur la console internet (depuis laquelle j'écris), seul Open office est installé.
Je vois cela ce soir depuis chez moi. Merci

**Theze** · 19/03/2013, 23h31

Bonsoir,

Comme pas de pj, regarde le code ci-dessous et test si plus rapide. Il te faut probablement adapter donc fait un test de préférence sur une copie de ton classeur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub CommandButton2_Click()
 
    Dim Lig1 As Integer
    Dim MaFeuille As Worksheet
    Dim Cel As Range
 
    Application.ScreenUpdating = False
 
    Feuil1.Range("A3:N6002").Clear
 
    Lig1 = 3
 
    For Each MaFeuille In Sheets
 
        If MaFeuille.Name Like "Act*" Then 'les feuilles concernées portent toutes un nom commançant par "Activités de..."
 
            With MaFeuille
 
                For Each Cel In .UsedRange.Columns(2).Cells.SpecialCells(xlCellTypeConstants)
 
                    Feuil1.Range(Feuil1.Cells(Lig1, 1), Feuil1.Cells(Lig1, 14)).Value = .Range(Cel.Offset(, -1), .Cells(Cel.Row, 14)).Value
 
                    Lig1 = Lig1 + 1
 
                Next
 
            End With
 
        End If
 
    Next MaFeuille
 
    Application.ScreenUpdating = True
 
End Sub

Hervé.

**mikadoo57** · 20/03/2013, 10h09

Bonjour,
avec un peu de retard voici une version très simplifiée de mon fichier.
Il est difficile de tester la vitesse d'exécution ici (chez moi) car ce fichier-test n'a que 10 entrées sur 3 feuilles alors que l'original fusionne actuellement 1300 lignes environ.

J'ai testé ton code, il fonctionne mais la ligne 2 (titre des colonnes) des feuilles ACT est recopiée! Je pense que cela vient du 'Cel.Row'

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Feuil1.Range(Feuil1.Cells(Lig1, 1), Feuil1.Cells(Lig1, 14)).Value = .Range(Cel.Offset(, -1), .Cells(Cel.Row, 14)).Value

qui prend toutes les lignes.

**Theze** · 20/03/2013, 18h43

Bonsoir,

Comme ça peut être ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Feuil1.Range(Feuil1.Cells(Lig1, 1), Feuil1.Cells(Lig1, 14)).Value = .Range(Cel.Offset(1, -1), .Cells(Cel.Row + 1, 14)).Value

Hervé.

**mikadoo57** · 20/03/2013, 19h24

Je n'ai plus la recopie de la ligne 2 mais la recopie de la ligne vide immédiatement après la dernière ligne non vide de chaque feuille

**Daniel.C** · 20/03/2013, 20h44

A tester sur un classeur volumineux :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Test()
 
    Dim Lig1 As Integer         'Lig1 est un entier
    Dim Col1 As Integer         'Col1 est un entier
    Dim MaFeuille As Worksheet  'MaFeuille est une feuille
    Dim Ligne As Integer        'Ligne est un entier
    Dim Result()
    Dim Tabl
 
    Application.ScreenUpdating = False
    For Each MaFeuille In Sheets
        Ligne = Ligne + MaFeuille.Cells(MaFeuille.Rows.Count, 1).End(xlUp).Row
    Next MaFeuille
    ReDim Result(14, Ligne)
    With Feuil1
        If Application.CountA(Feuil1.Range("A:A")) > 1 Then
            .Range(.[A3], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 14).ClearContents
            End If
    End With
    Lig1 = 1
        For Each MaFeuille In Sheets
        If MaFeuille.Name Like "Act*" Then 'les feuilles concernées portent toutes un nom commançant par "Activités de..."
            With MaFeuille
                 Tabl = Application.Transpose(.Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 14))
                 For Ligne = 1 To UBound(Tabl, 2) 'pour info, en mettant ...=3 To 1200, le temps d'exécution est le même
                   If Tabl(2, Ligne) <> "" Then
                         For Col1 = 1 To 14 'chaque tableau à 14 colonnes
                             Result(Col1, Lig1) = Tabl(Col1, Ligne)
                         Next
                         Lig1 = Lig1 + 1
                     End If
                 Next
            End With
          End If
    Next
    Feuil1.[A3].Resize(UBound(Result, 2), 14) = Application.Transpose(Result)
 
    Application.ScreenUpdating = True
End Sub

**mikadoo57** · 21/03/2013, 09h07

Merci Daniel pour ce code. Cependant, il recopie bien les lignes non vides sur le tableau de synthèse mais il y a un décalage d'une ligne et d'une colonne (la recopie commence en B4, ce qui fait que la colonne A est vide ainsi que la ligne 3). J'ai bien essayé de tripatouiller le code mais sans succès!
Côté rapidité d'exécution, j'ai "tiré" 1200 lignes sur chacune des feuilles "Act*" et cela me parait (c'est très subjectif) un poil plus rapide que le code de Theze.

**Daniel.C** · 21/03/2013, 10h03

Bonjour,

Il doit y avoir une différence entre ton classeur de test et celui que tu as mis en PJ. Je te retourne celui-ci avec la feuille "synthese" remplie. Tu peux l'effacer (la macro le fait de toutes façons) et relancer celle-ci. Je ne constate pas de décalage.

**Daniel.C** · 21/03/2013, 10h14

Oups.

Effectivement, j'ai oublié d'indiquer qu'il faut mettre la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Option Base 1

en tête du module.

Pour mesurer le temps d'exécution, lance cette macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub Mesure()
    Dim Deb As Double
    Deb = Timer
    Test
    MsgBox "temps d'exécution : " & Timer - Deb
End Sub

**mikadoo57** · 21/03/2013, 10h48

Maintenant c'est OK !
Pour la macro de mesure, où faut-il la placer ? Je n'ai jamais fais cette manip

C'est bon. J'ai trouvé! le temps d'exécution est de 2,4 secondes.

Je viens de tester le timer avec le code de Theze : <1,5 seconde donc c'est très intéressant pour accélérer la macro mon fichier original (dont le temps d’exécution sur le même fichier test est >4,5 secondes !!!).
Le seul problème est cette recopie en bas de chaque tableau d'une ligne vide et du haut de ma maitrise du VBA, je ne vois pas où apporter la correction. Je pense que le souci est dans la ligne 18 car avec la syntaxe '.Cells(Cel.Row, 14)' la ligne 2 (titre des colonnes) des tableaux est recopiée et en corrigeant avec '.Cells(Cel.Row + 1, 14)' la ligne 2 n'est plus recopiée mais il y a celle d'une ligne vide en fin de tableau.
Voici le code utilisé et en PJ le fichier test :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub import_fusion()
 'Call import
 
Dim Lig1 As Integer
Dim MaFeuille As Worksheet
Dim Cel As Range
 Dim Deb As Double
 
Deb = Timer
Application.ScreenUpdating = False
 
    Feuil1.Range("A3:N6002").Clear
     Lig1 = 3
         For Each MaFeuille In Sheets
         If MaFeuille.Name Like "Act*" Then
             With MaFeuille
                 For Each Cel In .UsedRange.Columns(2).Cells.SpecialCells(xlCellTypeConstants)
                     Feuil1.Range(Feuil1.Cells(Lig1, 1), Feuil1.Cells(Lig1, 14)).Value = .Range(Cel.Offset(1, -1), .Cells(Cel.Row + 1, 14)).Value
                     Lig1 = Lig1 + 1
                Next
             End With
         End If
 
    Next MaFeuille
 
     Call format
   'Call Sup_Vides
 
 MsgBox "temps d'exécution : " & Timer - Deb
 
    Application.ScreenUpdating = True
 
End Sub

**Daniel.C** · 21/03/2013, 17h05

Je n'ai pas retrouvé ma macro dans le classeur. Je l'ai ajouté dans le module "Daniel". Regarde le classeur en PJ.

**Daniel.C** · 21/03/2013, 17h08

Oops, je pense que le message de 10:48 ne m'était pas adressé. Désolé.

**mikadoo57** · 21/03/2013, 18h54

Merci Daniel pour le code. Cela fonctionne parfaitement : 1,3 sec pour 3 fois 1200 lignes!
Le message de 10h48 s'adressait à toi pour te dire que le code de Theze était un poil plus rapide que le premier que tu m'as donné mais avec ce souci sur la ligne vide ajoutée à la fin de chaque tableau copié.
Merci pour votre aide à tous les deux. Je marque résolu

(et maintenant je sais en plus comment faire pour avoir la vitesse d'exécution d'une procédure

)

**mikadoo57** · 26/03/2013, 10h23

Me revoici car j'ai un souci une fois le code appliqué au fichier original.
Pourtant, le fichier test sur lequel le code fonctionne à la même structure de fichier, de feuille et tableau que l'original (seuls les titres et types de données ont été changés).
Lorsque je lance la macro pour fusionner les tableaux du fichier, j'ai le message d'erreur suivant : "Erreur '-2147417848(80010108) erreur d'Automation L'objet invoqué s'est déconnecté de ses clients" et dans le débogueur, la ligne 4 de l'extrait du code ci-dessous est surligné en jaune. J'avoue rester perplexe !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
For Each MaFeuille In Sheets
        If MaFeuille.Name Like "Act*" Then 
            With MaFeuille
                 Tabl = Application.Transpose(.Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 14))
                 For Ligne = 1 To UBound(Tabl, 2)
                   If Tabl(2, Ligne) <> "" Then
                         For Col1 = 1 To 14 
                             Result(Col1, Lig1) = Tabl(Col1, Ligne)
                         Next
                         Lig1 = Lig1 + 1

Je viens de regarder le fichier original t l'un des tableaux est vide. Je pense que cela vient de la car en intégrant "on error resume next" juste avant la ligne de code "Tabl=...", la fusion des tableaux non vides s'effectue correctement.
Je confirme et vous tiens au courant

**Daniel.C** · 26/03/2013, 11h12

Bonjour,

Ta feuille comporte combien de lignes ?

**mikadoo57** · 26/03/2013, 12h24

Bonjour Daniel,
La macro d'importation des tableaux depuis les 7 autres fichiers prend les lignes non vides de 3 à 1202 (on a estimé que chaque utilisateur aurait environ 8 à 900 lignes à remplir/an, donc on a pris large)
La macro de fusion compte et compile donc 1200 lignes x 7 au maximum.
J'ai fait un test sur une copie de mon fichier original en retirant la feuille dont le tableau est vide (pas d'utilisateur encore affecté) et l'erreur se reproduit.
Chose bizarre : avec le "on error resume next", la compilation sur la fiche synthèse se fait bien mais le "call Format" (pour mettre en forme les cellules) ne s'exécute pas (même en allant dans l'éditeur et en cliquant sur F5)!
Comme je te l'ai dit, impossible de mettre le fichier original confidentiel et ici, réseau fermé et très protégé (clouding, pas de prises média actives sur nos stations..)

Optimiser une macro

Macros et VBA Excel

Discussions similaires

Partager

Partager