Macro trop lente

Le 13/04/2017 à 11:17

Bonjour,

Suite à mes premiers essais qui n'était que des bride de texte piochée à droite et gauche, je me suis enfin décidé d'écrire ma première page de VBA toute seul.... Et ça a marché, j'arrive à faire tout se que je veux et comme je le veux c'est top.

Mon problème pour lequel je m'adresse a vous c'est que ce macro prend au moins 5 a 10 min à s'executer du coup je voulais voir avec vous si vous aveiez des solutions à m'apporter

VOici le porgramme:

Sub ExportLot()

Dim Cl As Workbook

Dim Fe As Worksheet

Set Fe = Worksheets("RT-C")

Application.ScreenUpdating = False

With Cl

'Ouvre modèle Facturation Lot (Modèle)

Set Cl = Workbooks.Add("Traitement Cicm\Facturation Lot (Modèle).xltx")

'Copie les cellules et les cole en valeur au bon endroit

Windows("Gestion BRC.xlsm").Activate

Sheets("RT-C").Select

Cells.Select

Range("A5:AH3000").Select

Application.CutCopyMode = False

Selection.Copy

Cl.Sheets("RT-C").Activate

Range("A5").Select

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

:=False, Transpose:=False

ActiveWindow.SmallScroll Down:=117

Windows("Gestion BRC.xlsm").Activate

'Supprime des colones et agrandis une autre

Cl.Sheets("RT-C").Activate

Columns("AE:AF").Select

Selection.Delete Shift:=xlToLeft

Columns("Z:AC").Select

Selection.Delete Shift:=xlToLeft

Columns("Y:Y").Select

Selection.ColumnWidth = 60

'SUPPRIMER LES LIGNES EN FONCTION DE 1 CASES SUR AUTRE FEUILLE

Cl.Sheets("RT-C").Select

Set liste = CreateObject("scripting.dictionary")

With Sheets("BORD fin de lot")

For Each C In .[B6]

If C <> 0 Then liste(C.Value) = ""

Next C

End With

For lig = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1

If Cells(lig, 2) <> "" Then

If Not liste.exists(1 * Cells(lig, 2)) Then Rows(lig).EntireRow.Delete

End If

Next lig

'Copie des formules

Cl.Sheets("BORD fin de lot").Activate

Range("B14").FormulaLocal = "='RT-C'!$I$5"

Range("E10").Formula = "='RT-C'!G5"

'Copie feuille BORD fin de lot et la colle au même endroit en valeur

Cl.Sheets("BORD fin de lot").Select

Cells.Select

Selection.Copy

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

:=False, Transpose:=False

'Séléctionne BORD fin de lot pour mettre en valeur B6

Cl.Sheets("BORD fin de lot").Select

'Enregistre au bon endroit avec la variable en B6

Cl.SaveAs (ThisWorkbook.Path & "\" & "Facturation Lot" & "\" & "Facturation lot " & [B6].Value & " Nancy CICM - Oti France" & " " & " - " & Format(Date, "yyyy") & ".xls")

'Ferme le nouveau fichier

Workbooks("Facturation lot " & [B6].Value & " Nancy CICM - Oti France" & " " & " - " & Format(Date, "yyyy") & ".xls").Close

End With

Application.ScreenUpdating = True

Set Fe = Nothing

Set Cl = Nothing

End Sub

Je ne vois qu'une chose qui serait modifiable pour peut être donner un peu de rapidité et ca se trouve au niveau de "supprimer des lignes en fonction d'une valeur". Dans ma démarche cette page est copié sur une autre du même nom puis aprés chaque ligne est vérifié et suprrimée si elle ne comporte pas la valeur voulu. Je me dit qu'on pourrait peut etre ne copier directement que les bonnes lignes evitant ainsi un copié collé puis une suppression de ligne, qu'en dites vous???

Sinon vous verriez autre chose?

Le 13/04/2017 à 13:28

Bonjour

Pas facile sans voir votre fichier.

Comme premier jet le début du code peut être, je pense, modifié comme ceci

'Ouvre modèle Facturation Lot (Modèle)
Set Cl = Workbooks.Add("Traitement Cicm\Facturation Lot (Modèle).xltx")

'Copie les cellules et les cole en valeur au bon endroit
 Workbook("Gestion BRC.xlsm").Sheets("RT-C").Range("A5:AH3000").Copy
 Cl.Sheets("RT-C").Range("A5").PasteSpecial Paste:=xlPasteValues ', Operation:=xlNone, SkipBlanks _

'Supprime des colones et agrandis une autre
 With Cl.Sheets("RT-C")
    .Columns("AE:AF").Delete Shift:=xlToLeft
    .Columns("Z:AC").Delete Shift:=xlToLeft
    .Columns("Y:Y").ColumnWidth = 60
End With
 'SUPPRIMER LES LIGNES EN FONCTION DE 1 CASES SUR AUTRE FEUILLE

Enlever aussi le With CI tout au début du code et le End with à la fin

Cordialement

Le 13/04/2017 à 14:21

Merci pour ce début de réponse.

Voici le nouveau code avec des modifications:

Sub ExportLot()

Dim Cl As Workbook

Dim Fe As Worksheet

Set Fe = Worksheets("RT-C")

'Augmenter rapidité

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'Ouvre modèle Facturation Lot (Modèle)

Set Cl = Workbooks.Add("Traitement Cicm\Facturation Lot (Modèle).xltx")

'Copie les cellules et les cole en valeur au bon endroit

Workbooks("Gestion BRC.xlsm").Sheets("RT-C").Range("A5:AH3000").Copy

Cl.Sheets("RT-C").Range("A5").PasteSpecial Paste:=xlPasteValues ', Operation:=xlNone, SkipBlanks _

'Supprime des colones et agrandis une autre

With Cl.Sheets("RT-C")

.Columns("AE:AF").Delete Shift:=xlToLeft

.Columns("Z:AC").Delete Shift:=xlToLeft

.Columns("Y:Y").ColumnWidth = 60

End With

'Remettre Calcul pour les fonctions suivantes

Application.Calculation = xlCalculationAutomatic

'SUPPRIMER LES LIGNES EN FONCTION DE 1 CASES SUR AUTRE FEUILLE

Cl.Sheets("RT-C").Select

Set liste = CreateObject("scripting.dictionary")

With Sheets("BORD fin de lot")

For Each C In .[B6]

If C <> 0 Then liste(C.Value) = ""

Next C

End With

For Lig = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1

If Cells(Lig, 2) <> "" Then

If Not liste.exists(1 * Cells(Lig, 2)) Then Rows(Lig).EntireRow.Delete

End If

Next Lig

With Cl.Sheets("BORD fin de lot")

'Copie des formules

Range("B14").FormulaLocal = "='RT-C'!$I$5"

Range("E10").Formula = "='RT-C'!G5"

'Enlever le calcul automatique

Application.Calculation = xlCalculationManual

'Copie feuille BORD fin de lot et la colle au même endroit en valeur

Cells.Select

Selection.Copy

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

:=False, Transpose:=False

'Séléctionne BORD fin de lot pour mettre en valeur B6 et Enregistre au bon endroit avec la variable en I20

Cl.SaveAs (ThisWorkbook.Path & "\" & "Facturation Lot" & "\" & "Facturation lot " & [B6].Value & " Nancy CICM - Oti France" & " " & " - " & Format(Date, "yyyy") & ".xls")

End With

'Ferme le nouveau fichier

Workbooks("Facturation lot " & [B6].Value & " Nancy CICM - Oti France" & " " & " - " & Format(Date, "yyyy") & ".xls").Close

'Arrête les setting

Set Fe = Nothing

Set Cl = Nothing

'Remettre les paramètres normaux

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub

Ca ne m'accélère quasiement pas... Le problème dans ma macro est que je prend 3000 Ligne d'une feuille pour aller les coller sur une autre et qu'aprés je supprime toutes les lignes ne correspondant pas aux critères pour n'en laisser que 150 (valeur fixe) il faudrait que je trouve un moyen de ne selectionner que les 150 et de les copier en valeur au bon endroit ca m'évitera la plus grosse des manipulations

Autre question:

A l'ouverture de mes fichiers j'ai un message d'erreur me disant que le format et l'extension ne correspondent pas est ce que vous savez comment palier à se problème?

Le 14/04/2017 à 08:31

Bonjour

Possible d'avoir votre fichier ce sera plus simple. (sans données confidentielles)

Cordialement

Rechercher des sujets similaires à "macro trop lente"