Optimisation de macro copier / coller

Version imprimable

Bonjour,

quasi débutant en VB, je cherche à optimiser cette macro, car j'ai beaucoup de lignes à traiter et pour le moment la macro tourne pendant 1h30.

Mon onglet "Planning" contient mes données que je dois réorganiser pour les mettre sous forme base de données, dans l'onglet "PBD".

Avez vous des idées pour utiliser un copy avec destination directement, sachant que j'ai des conditions sur les copies et sur les destinations.

Vous trouverez ci dessous la macro :

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
Sub transformation_planning_sup_si()
 
Sheets("PLANNING").Activate
DernLigne = Range("C" & Rows.Count).End(xlUp).Row
 
For i = 18 To DernLigne
Sheets("PLANNING").Select
    If Cells(i, 3) <> "" And Cells(i, 8) <> "PLANNING GENERAL" And Cells(i, 8) <> "à définir" Then
        For j = 15 To 365
        Sheets("PLANNING").Select
            If Cells(i, j) <> "" Then
            Range(Cells(i, 3), Cells(i, 14)).Select
            Selection.Copy
            Sheets("PBd").Select
                For k = 2 To 60000
                If Cells(k, 1) = "" Then
                Cells(k, 1).Select
                ActiveSheet.Paste
                Sheets("PLANNING").Select
                Cells(17, j).Select
                ActiveCell.Copy
                Sheets("PBd").Select
                Cells(k, 13).Select
                ActiveSheet.Paste
                k = 60000
                End If
                Next k
            End If
        Next j
    End If
j = 17
Next i
 
Sheets("PBD").Activate
Dernligne2 = Range("C" & Rows.Count).End(xlUp).Row
 
For i = 2 To Dernligne2
 
Sheets("PBd").Select
 
        For j = 7 To 121
 
        If Cells(i, 13).Value = Sheets("jf").Cells(j, 3).Value Then
         Rows(i).Delete
         i = i - 1
 
 
 
    End If
 
Next j
 
Next i
 
End Sub

Merci à vous!

29/06/2015, 18h37
Marc-L

Bonjour,

sans détailler le code, il faudrait revoir sa conception : éviter de copier ligne à ligne
mais par lot par condition via par exemple un filtre ou un filtre avancé …

Qui plus est un bon code n'a pas besoin de sélectionner pour copier comme dans cette discussion …
La sélection et son actualisation à l'écran ralentit considérablement l'exécution d'une procédure.

A minima, tenter la désactivation de l'affichage durant la procédure via Application.ScreenUpdating = False …

_____________________________________________________________________________________________________
Je suis Charlie, Bardo, Sousse

Bonjour
je n'ai pas testé mais ca doit donner ca sans sélection ni activâtes

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
Sub transformation_planning_sup_si()
    'Sheets("PLANNING").Activate
    DernLigne = Range("C" & Rows.Count).End(xlUp).Row
    With Sheets("PLANNING")
        For i = 18 To DernLigne
            If .Cells(i, 3) <> "" And .Cells(i, 8) <> "PLANNING GENERAL" And .Cells(i, 8) <> "à définir" Then
                For j = 15 To 365
                     If .Cells(i, j) <> "" Then
                                Sheets("PBd").Cells(Rows.Count, 1).End(xlUp) .offset(1,0)= .Range(.Cells(i, 3), .Cells(i, 14))
                                Sheets("PBd").Cells(Rows.Count, 13).End(xlUp) .offset(1,0)=  .Cells(17, j)
                     end If
                Next j
            End If
        Next i
    End With
    With Sheets("PBD")
        Dernligne2 = .Range("C" & Rows.Count).End(xlUp).Row
        For i = 2 To Dernligne2
            'ici dans cette boucle tu suprime ligne par ligne ce qui reviens au meme qu'une selection
            'je te suggere d'utiliser une variable de type range que tu instruirais avec la fonction "union"
            'et des que la boucle est fini "tavariable.entirerow.delete"
            For j = 7 To 121
                If .Cells(i, 13).Value = Sheets("jf").Cells(j, 3).Value Then
                    .Rows(i).Delete
                    i = i - 1
                End If
            Next j
        Next i
    End With
End Sub

OUPSSS J AVAIS OUBLIE D ENLEVER LA BOUCLE "K"!!!!!!!!!!!

voir même pour la 2 eme partie passer par l'interrogation avec la fonction "find"

Code:

1
2
3
4
5
6
7
8
9
With Sheets("PBD")
        Dernligne2 = .Range("C" & Rows.Count).End(xlUp).Row
        For i = 2 To Dernligne2
            If Not Sheets("jf").Range(Cells(7, 3), Cells(121, 3)).Find(.Cells(i, 13).Value) Is Nothing Then
                .Rows(i).Delete
                i = i - 1
            End If
        Next i
    End With

Cela fonctionne avec un peu d'huile de coude

Merci beaucoup!

Avec le code que tu as fait le début de la ligne ne se copiait pas donc j'ai fait cela :

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
Sub Macro1()
 
Sheets("PLANNING").Activate
    DernLigne = Range("C" & Rows.Count).End(xlUp).Row
 
    With Sheets("PLANNING")
        For i = 18 To DernLigne
            If .Cells(i, 3) <> "" And .Cells(i, 8) <> "PLANNING GENERAL" And .Cells(i, 8) <> "à définir" Then
 
                For j = 15 To 365
                     If .Cells(i, j) <> "" Then
                                For k = 3 To 13
                                Sheets("PBD").Cells(Rows.Count, k - 2).End(xlUp).Offset(1, 0) = .Cells(i, k)
                                Next k
                      Sheets("PBD").Cells(Rows.Count, 13).End(xlUp).Offset(1, 0) = .Cells(17, j)
                     End If
                Next j
 
            End If
        Next i
    End With
    With Sheets("PBD")
        Dernligne2 = .Range("C" & Rows.Count).End(xlUp).Row
        For i = 2 To Dernligne2
                       For j = 7 To 121
                If .Cells(i, 13).Value = Sheets("jf").Cells(j, 3).Value Then
                    .Rows(i).Delete
                    i = i - 1
                End If
            Next j
        Next i
    End With
End Sub

J'ai pas encore modifié la fin et j'ai remis le 1er activate (pensez vous que celui ci ralentisse?). Je vais finaliser tout cela pour que cela soit propre. et surtout tester sur mon fichier source.

L'ancienne version tournait pendant 1h30 environ. Avec ce nouveau code, cela met 8 minutes ! Vraiment impressionnant.

Encore merci, c'est génial!

30/06/2015, 19h41
patricktoulon

re

a la fin de la semaine je te ferait un autre exemple avec une autre méthode elle devrait diviser des 8 minutes par 4 au moins
pour le moment je suis over jusqu'à la fin de la semaine
30/06/2015, 21h50
jdeveau

C est sympa, merci.

Pour info la partie permettant la suppression avec le range ne fonctionne pas et je ne m en sors pas...
J attends donc avec impatience.

re

tiens en attendant la raison de ta réutilisation du activâtes était flagrante
ca m'a échappé

a la place de comme ca:
Code:

1 2 3 4 Sub transformation_planning_sup_si() Sheets("PLANNING").Activate DernLigne = Range("C" & Rows.Count).End(xlUp).Row With Sheets("PLANNING")
tu fais
Code:

1 2 3 4 Sub transformation_planning_sup_si() With Sheets("PLANNING") DernLigne = .Range("C" & Rows.Count).End(xlUp).Row