Optimisation Macro VBA

[ninou58]

Bonjour,

j'aurais besoin de vos conseils dans le but d'optimiser ma macro.
Alors j'ai 2 fichiers excel qui ont tous les deux, 2 onglets.

Pour chaque fichier, et chaque onglet je lance ma macro tour à tour.
c'est une histoire de mise en forme
fichier d'origine :
codeart l cajanv lqtéjanv l cafev .....

Fichier de destination
codeart l qte l ca l mois l annee

Au lieu d'avoir les qté et ca en colonne c'est en ligne.
pour le 1er onglet (1800lignes) : 10min
le second (400lignes) :2 min
...

Bref 30 min presque pour tout.
Pouvez vous me conseiller?
Merci d'avance
Voici ma macro :

Sub Transformation2()

'nom des fichiers dans les variables
nomf1 = "fina1.xls"
nomf2 = "fina2.xls"

'ouverture des fichiers fina1 et fina2
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf1
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf2

Windows(nomf1).Activate
If MsgBox("Voulez vous effacer les anciennes données?", vbYesNo, "Données") = vbYes Then
Windows("fina2.xls").Activate
Columns("A:G").Select
Selection.ClearContents
Windows("fina1.xls").Activate
Columns("A:E").Select
Selection.ClearContents
End If
'en tete fichier 1
Windows(nomf1).Activate
Range("A1").Select
ActiveCell.FormulaR1C1 = "Id"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Client"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Vehicule"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Usine"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Code article"
Range("F1").Select

'en tete fichier 2
ActiveCell.FormulaR1C1 = ""
Windows(nomf2).Activate
'en tete du second fichier
Range("A1").Select
ActiveCell.FormulaR1C1 = "Code article"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Client"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Quantité"
Range("D1").Select
ActiveCell.FormulaR1C1 = "CA"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Véhicule"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Mois"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Année"

'compte le nombre de ligne non vides
Windows(nomf1).Activate
dl = Sheets("feuil1").Range("A" & "65536").End(xlUp).Row

' nombre de ligne dans le fichier d'origine
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
dl1 = Sheets("suivi écarts TO").Range("A" & "65536").End(xlUp).Row

'plage de selection

zone = "A7:C" & dl1 & ",K7:K" & dl1 & ",N7:N" & dl1
Range(zone).Select

'copie de la plage
Selection.Copy
Windows(nomf1).Activate
cellule = "A" & dl + 1
Range(cellule).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("A1") = "" Then
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If


' colonne code article
co1 = 14
'colonne client
co2 = 2
'1ère colonne qté
co3 = 41
'1ère colonne ca
co4 = 90
'colonne vehicule
co5 = 3

'1ère colonne dans fichier fina code article
cofina = 1
cofina1 = 2
cofina2 = 3
cofina3 = 4
cofina4 = 5
cofina5 = 6
cofina6 = 7

'ligne depart du fichier d'origine
lignedeb = 4
' nombre de ligne dans le fichier fina2
Windows("fina2.xls").Activate
dl2 = Sheets("feuil1").Range("A" & "65536").End(xlUp).Row
lignearriv = dl2 + 1



'Pour j de 1 à la fin (nb de ligne non vide)
For j = 1 To dl1

'pour chaque mois
For mois = 1 To 12
' copie du code article
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
'valeur de code article dans la variable codeart
codeart = Cells(lignedeb, co1).Value
Windows(nomf2).Activate
'inserer dans la feuille la valeur codeart
Cells(lignearriv, cofina).Value = codeart


'copie du client
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
client = Cells(lignedeb, co2).Value
Windows(nomf2).Activate
Cells(lignearriv, cofina1).Value = client


'copie de la quantité

Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
qt = Cells(lignedeb, co3).Value
Windows(nomf2).Activate
Cells(lignearriv, cofina2).Value = qt


'copie du CA
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
CA = Cells(lignedeb, co4).Value
Windows(nomf2).Activate
Cells(lignearriv, cofina3).Value = CA



'copie du vehicule
Windows("suivi écarts CA 2008_PSA+TO.xls").Activate
vehic = Cells(lignedeb, co5).Value
Windows(nomf2).Activate
Cells(lignearriv, cofina4).Value = vehic


'ecriture du mois
Windows(nomf2).Activate
Cells(lignearriv, cofina5).Select
Cells(lignearriv, cofina5).Value = mois

'ecriture de l'année
Windows(nomf2).Activate
Cells(lignearriv, cofina6).Select
Cells(lignearriv, cofina6).Value = 2008

'ajoute 1 à la colonne des quantités
co3 = co3 + 4

'ajoute 4 à la colonne des CA
co4 = co4 + 4
lignearriv = lignearriv + 1
'si mois =12
If mois = 12 Then
'on ajoute 1 à la ligne de départ
lignedeb = lignedeb + 1
'on remet les colonnes à l'initial
co4 = 90
co3 = 41

End If

Next


Next

'sauvegarde
Windows(nomf1).Activate
ActiveWorkbook.Save
Windows(nomf2).Activate
ActiveWorkbook.Save
End Sub




Merci d'avance
Bonne journée

 

[ballmaster]

Re : Optimisation Macro VBA

Bonjour,

As-tu pensé à mettre en début de code :

application.screenupdating=false

et en fin de code :
application.screenupdating=true

 

[Luki]

Re : Optimisation Macro VBA

bonjour Ninou, ballmaster.

Sans réécrire tout ton code (je n'ai pas le temps!), un ou deux principes de base que tu ne semble pas encore connaître (l'enregistreur de macro n'est pas le champion de l'optimisation!)

Il est généralement inutile de passer par des sélections qui ralentissent le code pour ce genre d'actions. De plus, la méthode "Select" t'oblige à travailler sur la feuille active, donc à l'activer et à ralentir le code encore une fois.
ex:

     Range("A1").Select
    ActiveCell.FormulaR1C1 = "Id"

peut-être remplacé par

Range("A1")="Id"

C'est aussi efficace et plus rapide.

"Activate" devient très vite inutile si tu codes dans cet esprit.

dans le même principe, le transfert de valeurs entre 2 feuilles ou fichiers peut se faire sans copier coller qui devient assez lent lors de gros paquets de données:
un exemple ci-dessous.

Sub tranfertdonnées()

    Dim i As Integer
    Dim Rg1 As Range
    Dim Rg2 As Range
    
    ' définition des plages de données
    Set Rg1 = Workbooks("Fina1.xls").Worksheets(1).Range("A1:C10")
    Set Rg2 = Workbooks("Fina2.xls").Worksheets(1).Range("A1:C10")
    
    'transfert des données du fichier 1 vers le fichier 2 à l'aide d'une boucle sur la collection de cellules de la plage.
    For i = 1 To Rg1.Cells.Count
        Rg2(i) = Rg1(i)
    Next

End Sub

pour nettoyer tes feuilles et remettre tes entêtes, tu peux essayer ceci :

Sub nettoyer()
Dim nom1 As String
Dim nom2 As String

    nom1 = "Fina1.xls"
    nom2 = "Fina2.xls"
    'nettoyer les colonnes A à G de la feuille 1 de "FINA1"
    Workbooks(nom1).Worksheets(1).Columns("A:G").ClearContents
    
    'remplir les entêtes de cette même feuille
    '( a noter l'utilisation du bloc "With" qui évite la répétition de :Workbooks(nom1).Worksheets(1)
    ' et de fait acélération de l'éxécution du code.)
    With Workbooks(nom1).Worksheets(1)
        Range("A1") = "Id"
        Range("B1") = "Client"
        Range("C1") = "Vehicule"
        Range("D1") = "Usine"
        Range("E1") = "Code article"
    End With
    
End Sub

Voilà pour commencer quelques pistes. En espérant t'éclairer un peu....

Bonne journée

 

[ninou58]

Re : Optimisation Macro VBA

Bonjour,

Déjà merci de m'avoir répondu.
J'ai commencé les modifications concernant les en- tete.
A quoi sert application.screenupdating=false?
Je n'ai pas trop compris cette partie :
Sub tranfertdonnées()

Dim i As Integer
Dim Rg1 As Range
Dim Rg2 As Range

' définition des plages de données
Set Rg1 = Workbooks("Fina1.xls").Worksheets(1).Range("A1:C10")
Set Rg2 = Workbooks("Fina2.xls").Worksheets(1).Range("A1:C10")

'transfert des données du fichier 1 vers le fichier 2 à l'aide d'une boucle sur la collection de cellules de la plage.
For i = 1 To Rg1.Cells.Count
Rg2(i) = Rg1(i)
Next


tu définis une plage de données où seront copié les informations?


Merci d'avance
bonne journée

 

[ninou58]

Re : Optimisation Macro VBA

Re Bonjour,

Après quelques modifications, je passe de 10 min à moins d'une minute quel effet!

voici la nouvelle macro
je pense qu'il y a encore moyen de faire mieux mais après ca me dépasse un peu.

Option Explicit

Sub transformation()
'
'




'--------------------------------------------------DECLARATION DES VARIABLES--------------------------------------------------
Dim nomf1 As String
Dim nomf2 As String
Dim nom3 As String
Dim dl As Integer, dl1 As Integer, dl2 As Integer, dl3 As Integer
Dim zone As String
Dim cellule As String
Dim co1 As Integer ' colonne code article
Dim co2 As Integer 'colonne client
Dim co3 As Integer '1ère colonne qté
Dim co4 As Integer '1ère colonne budget
Dim co5 As Integer 'colonne vehicule

'1ère colonne dans fichier fina code article
Dim cofina As Integer
Dim cofina1 As Integer
Dim cofina2 As Integer
Dim cofina3 As Integer
Dim cofina4 As Integer
Dim cofina5 As Integer
Dim cofina6 As Integer
Dim lignedeb As Integer
Dim lignearriv As Integer
Dim mois As Integer
Dim j As Integer, A As Integer, y As Integer 'compteurs
Dim ro As String


'------------------------------------------------------------FIN DE DECLARATION -------------------------------------------------
'------------------------------------------------------------ DEBUT MACRO -------------------------------------------------
'desactive le rafraichissement
Application.ScreenUpdating = False

'nom des fichiers dans les variables
nomf1 = "fina1.xls"
nomf2 = "fina2.xls"
nom3 = "Suivi Ecarts CA 2008 RSA Nissan.xls"

'ouverture des fichiers fina1 et fina2
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf1
' Windows(nom3).Activate
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf2

If MsgBox("Voulez vous effacer les anciennes données?", vbYesNo, "Données") = vbYes Then nettoyer

'compte le nombre de ligne non vides

dl = Workbooks(nomf1).Sheets("feuil1").Range("A" & "65536").End(xlUp).Row

'nombre de ligne dans le fichier d'origine
dl1 = Workbooks(nom3).Sheets("RSA OEM").Range("A" & "65536").End(xlUp).Row

' nombre de ligne dans le fichier fina2
dl2 = Workbooks(nomf2).Sheets("feuil1").Range("F" & "65536").End(xlUp).Row




'plage de selection
Workbooks(nom3).Activate
zone = "A3:C" & dl1 & ",L3:L" & dl1 & ",O3:O" & dl1

'copie de la plage
Selection.Copy
cellule = "A" & dl + 1
Workbooks(nomf1).Activate
Range(cellule).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

If Range("A1") = "" Then
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If


' colonne code article
co1 = 15
'colonne client
co2 = 2
'1ère colonne qté
co3 = 43
'1ère colonne budget
co4 = 92
'colonne vehicule
co5 = 3

'1ère colonne dans fichier fina code article
cofina = 1
cofina1 = 2
cofina2 = 3
cofina3 = 4
cofina4 = 5
cofina5 = 6
cofina6 = 7

'ligne depart du fichier d'origine
lignedeb = 3

lignearriv = dl2 + 1


mois = 0
'Pour j de 1 à la fin (nb de ligne non vide)
For j = 1 To dl1

'pour chaque mois
For mois = 1 To 12

' copie du code article

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina).Value = Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co1).Value

'copie du client

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina1).Value = Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co2).Value

'copie de la quantité

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina2).Value = Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co3).Value

'copie du CA

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina3).Value = Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co4).Value

'copie du vehicule
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina4).Value = Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co5).Value

'ecriture du mois

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina5).Value = mois

'ecriture de l'année

Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina6).Value = 2008

'ajoute 1 à la colonne des quantités
co3 = co3 + 4

'ajoute 4 à la colonne des CA
co4 = co4 + 4
lignearriv = lignearriv + 1
'si mois =12
If mois = 12 Then

lignedeb = lignedeb + 1
'on remet les colonnes à l'initial
co4 = 92
co3 = 43

End If

Next


Next
dl2 = Workbooks(nomf2).Sheets("feuil1").Range("F" & "65536").End(xlUp).Row
For A = 2 To dl2

If Range("A" & A) = "" Then
For y = A To dl2
ro = A & ":" & A
Rows(ro).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Next
A = y

End If
Next
'sauvegarde et fermeture
Workbooks(nomf1).Save
Workbooks(nomf2).Save

Application.ScreenUpdating = True
End Sub
----------------------------------------------------------
Sub nettoyer()
Dim nom1 As String
Dim nom2 As String

nom1 = "fina1.xls"
nom2 = "fina2.xls"
'nettoyer les colonnes A à G de la feuille 1 de "FINA1"
Workbooks(nom1).Worksheets(1).Columns("A:G").ClearContents
Workbooks(nom2).Worksheets(1).Columns("A:G").ClearContents
'remplir les entêtes de cette même feuille
'( a noter l'utilisation du bloc "With" qui évite la répétition de :Workbooks(nom1).Worksheets(1)
' et de fait accélération de l'éxécution du code.)

Workbooks(nom1).Worksheets(1).Activate
Range("A1") = "Id"
Range("B1") = "Client"
Range("C1") = "Vehicule"
Range("D1") = "Usine"
Range("E1") = "Code article"


Workbooks(nom2).Worksheets(1).Activate
'en tete du second fichier
Range("A1") = "Code article"
Range("B1") = "Client"
Range("C1") = "Quantite"
Range("D1") = "CA"
Range("E1") = "Vehicule"
Range("F1") = "Mois"
Range("G1") = "Annee"


End Sub

Pour la procédure nettoyer le with ne fonctionnait pas. J'ai fait ainsi est-ce correct?


Merci

 

[Staple1600]

Re : Optimisation Macro VBA

Bonjour



A tester

Option Explicit

Sub transformation()
'-----DECLARATION DES VARIABLES---
'Strings
Dim nomf1$, nomf2$, nom3$, zone$, cellule$, ro$
Dim dl%, dl1%, dl2%, dl3%
Dim co1%, co2%, co3%, co4%, co5%
'1ère colonne dans fichier fina code article
Dim cofina%, cofina1%, cofina2%, cofina3%, cofina5%, cofina6%
Dim lignedeb%, lignearriv%
Dim mois%
Dim j%, A%, y% 'compteurs

'--FIN DE DECLARATION ---
'---DEBUT MACRO ---
'desactive le rafraichissement
Application.ScreenUpdating = False
'nom des fichiers dans les variables
nomf1 = "fina1.xls": nomf2 = "fina2.xls": nom3 = "Suivi Ecarts CA 2008 RSA Nissan.xls"
'ouverture des fichiers fina1 et fina2
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf1
' Windows(nom3).Activate
Workbooks.Open Filename:= _
"C:\Documents and Settings\user\Mes documents\" & nomf2

If MsgBox("Voulez vous effacer les anciennes données?", vbYesNo, "Données") = _
vbYes Then nettoyer
'compte le nombre de ligne non vides
dl = Workbooks(nomf1).Sheets("feuil1").Range("A" & "65536").End(xlUp).Row
'nombre de ligne dans le fichier d'origine
dl1 = Workbooks(nom3).Sheets("RSA OEM").Range("A" & "65536").End(xlUp).Row
' nombre de ligne dans le fichier fina2
dl2 = Workbooks(nomf2).Sheets("feuil1").Range("F" & "65536").End(xlUp).Row
'plage de selection
Workbooks(nom3).Activate
zone = "A3:C" & dl1 & ",L3:L" & dl1 & ",O3:O" & dl1
'copie de la plage
Selection.Copy
cellule = "A" & dl + 1
Workbooks(nomf1).Activate
Range(cellule).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("A1") = "" Then
Rows("1:1").Delete Shift:=xlUp
End If
co1 = 15: co2 = 2: co3 = 43: co4 = 92: co5 = 3
'1ère colonne dans fichier fina code article
cofina = 1: cofina1 = 2: cofina2 = 3: cofina3 = 4
cofina4 = 5: cofina5 = 6: cofina6 = 7
'ligne depart du fichier d'origine
lignedeb = 3: lignearriv = dl2 + 1: mois = 0
'Pour j de 1 à la fin (nb de ligne non vide)
For j = 1 To dl1
'pour chaque mois
For mois = 1 To 12
' copie du code article
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina).Value = _
Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co1).Value
'copie du client
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina1).Value = _
Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co2).Value
'copie de la quantité
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina2).Value = _
Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co3).Value
'copie du CA
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina3).Value = _
Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co4).Value
'copie du vehicule
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina4).Value = _
Workbooks(nom3).Sheets("RSA OEM").Cells(lignedeb, co5).Value
'ecriture du mois
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina5).Value = mois
'ecriture de l'année
Workbooks(nomf2).Sheets("feuil1").Cells(lignearriv, cofina6).Value = 2008
'ajoute 1 à la colonne des quantités
co3 = co3 + 4
'ajoute 4 à la colonne des CA
co4 = co4 + 4
lignearriv = lignearriv + 1
'si mois =12
If mois = 12 Then
lignedeb = lignedeb + 1
'on remet les colonnes à l'initial
co4 = 92: co3 = 43
End If
Next
Next
dl2 = Workbooks(nomf2).Sheets("feuil1").Range("F" & "65536").End(xlUp).Row
For A = 2 To dl2
If Range("A" & A) = "" Then
For y = A To dl2
ro = A & ":" & A
Rows(ro).Delete Shift:=xlUp
Next
A = y
End If
Next
'sauvegarde et fermeture
Workbooks(nomf1).Save: Workbooks(nomf2).Save
Application.ScreenUpdating = True
End Sub

Sub nettoyer()
Dim nom1$, nom2$
nom1 = "fina1.xls": nom2 = "fina2.xls"
'nettoyer les colonnes A à G de la feuille 1 de "FINA1"
Workbooks(nom1).Worksheets(1).Columns("A:G").Clear Contents
Workbooks(nom2).Worksheets(1).Columns("A:G").Clear Contents
'remplir les entêtes de cette même feuille
'( a noter l'utilisation du bloc "With"
'qui évite la répétition de :Workbooks(nom1).Worksheets(1)
' et de fait accélération de l'éxécution du code.)

Workbooks(nom1).Worksheets(1).Activate
Range("A1") = "Id"
Range("B1") = "Client"
Range("C1") = "Vehicule"
Range("D1") = "Usine"
Range("E1") = "Code article"

Workbooks(nom2).Worksheets(1).Activate
'en tete du second fichier
Range("A1") = "Code article"
Range("B1") = "Client"
Range("C1") = "Quantite"
Range("D1") = "CA"
Range("E1") = "Vehicule"
Range("F1") = "Mois"
Range("G1") = "Annee"
End Sub

 

[ninou58]

Re : Optimisation Macro VBA

Bonjour,

Pouvez vous m'expliquer,qu'est que les pourcentages après le nom des variables?

Je vais tester cela

Merci

 

[Staple1600]

Re : Optimisation Macro VBA

Re


Explications—›•

 

[ninou58]

Re : Optimisation Macro VBA

Merci pour votre réponse.
J'aurais appris quelque chose !

Bonne journée