Raccourcir la durée d'ouverture et d'enregistrement d'une macro ?

J

jcsellas

XLDnaute Nouveau
Bonjour a tous,
Je suis semi-débutant en vba et j'ai réalisé une grosse macro pour le taf mais le probleme c'est que l'ouverture et l'enregistrement du fichier excel est super long.
Je voulais savoir si il existait un moyen de raccourcir cette durée ?

Je pense que c'est a cause de la longueur du code et du nombre de feuille créer (6) mais en fait je n'en sais rien, alors je sollicite tous les experts en vba

Voici le code : (dsl c'est assez lourd mais je vois pas comment faire)

'Récuperation des données

If MsgBox("Avez-vous supprimer la feuille BASE DQIE avant d'executer la macro", vbYesNo) _
= vbYes Then

'ouvrir fichier Source

Workbooks.Open Filename:="Y:\controle financier\Directions de production\Industrie\Gestion DQIE\EXIGIBLE\Exigible DQIE1.xls"
Windows("Exigible DQIE1.xls").Activate


Sheets("Date").Select
Range("C11").Select
ActiveCell.FormulaR1C1 = InputBox("Veuillez entrer la date de fin, de la dernière période de prévision d'encaissement sous forme MM/JJ/AAAA")
Range("C12").Select
Sheets("Base DQIE").Select
Sheets("Base DQIE").Copy Before:=Workbooks("Prev Encaissement.xlsm").Sheets(1)
Sheets("critère").Select

'supréssion des ligne

Rows("10:10").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp

'filtre élaboré

Range("A10").Select
Sheets("Base DQIE").Columns("A:M").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("critère!Criteria"), CopyToRange:=Range("A10"), _
Unique:=True
'modif
Sheets("base").Select
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
'fin

Sheets("critère").Select
Rows("10:10").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("base").Select
Range("A1").Select
ActiveSheet.Paste

'Récupération des données pour mois M+1 M+2 M+3

Sheets("base").Select
Range("N1").Select
Selection.Style = "Normal 2"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = 15
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.NumberFormat = "#,##0.00"
ActiveCell.FormulaR1C1 = "Mois"
With ActiveCell.Characters(Start:=1, Length:=4).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With


Range("N2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-7]="""","""",MONTH(RC[-7]))"
Range("N2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste
Range("N2").Select
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-21
Range("N3").Select

'mois M+1

Sheets("mois+1").Select
Rows("11:11").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A11").Select

Range("A8").Select
Sheets("base").Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("'mois+1'!Criteria"), CopyToRange:=Range("A10:N10"), _
Unique:=True

'Mois M+2

Sheets("mois+2").Select
Rows("11:11").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A14").Select
Sheets("base").Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("'mois+2'!Criteria"), CopyToRange:=Range( _
"'mois+2'!Extract"), Unique:=True

'Mois M+3

Sheets("mois+3").Select
Rows("11:11").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A15").Select
Sheets("base").Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("'mois+3'!Criteria"), CopyToRange:=Range( _
"'mois+3'!Extract"), Unique:=True

'Mois M + Exigible

Sheets("base").Select

Range("O1").Select
Selection.Style = "Normal 2"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = 15
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.NumberFormat = "#,##0.00"
ActiveCell.FormulaR1C1 = "Exigible"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With

'Formule dans la base pour l'exigible

Range("O2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]="""","""",SUMIF('mois+1'!C[-14],base!RC[-14],'mois+1'!C[-14])+SUMIF('mois+2'!C[-14],base!RC[-14],'mois+2'!C[-14])+SUMIF('mois+3'!C[-14],base!RC[-14],'mois+3'!C[-14]))"
Range("O2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=129
Range("M145").Select
ActiveWindow.SmallScroll Down:=-15



Range("O8").Select
Sheets("moisEXI").Select
Rows("11:11").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("A16").Select
ActiveWindow.SmallScroll Down:=-6
Sheets("base").Columns("A:O").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:O2"), CopyToRange:=Range("A10:O10"), Unique:= _
True
ActiveWindow.SmallScroll Down:=-6


Sheets("moisEXI").Select
Range("P10").Select
Selection.Style = "Normal 2"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = 15
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.NumberFormat = "#,##0.00"
ActiveCell.FormulaR1C1 = "Nbre de jr retard"
With ActiveCell.Characters(Start:=1, Length:=17).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With


' calcul du nombre de jour en retard

Range("P11").Select

ActiveCell.FormulaR1C1 = "=IF(RC[-3]="""","""",TODAY()-RC[-9])"
Range("P12").Select
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
Range("P11").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=3
Columns("P:p").Select
Range("P5").Activate
Application.CutCopyMode = False
Selection.NumberFormat = "#,##0"
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:="=30"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
ActiveWindow.SmallScroll Down:=3
Range("O30").Select
ActiveWindow.SmallScroll Down:=-9
' fin

'Ferme le Fichier source
Workbooks("Exigible DQIE1.xls").Close Savechanges:=False


End If


End Sub

Merci d'avance à ce qqui auront la patience de m'aider
 
Trier par date Trier par votes
jeanpierre

jeanpierre

Nous a quitté
Repose en paix
Re : Raccourcir la durée d'ouverture et d'enregistrement d'une macro ?

Bonjour jcsellas,

La première question à se demander, pour le temps de travail de VBA, est de dire est-ce que je ferai aussi bien ou mieux à la main ???

Certes on peut toujours alléger une procédure, la rendre plus simple, plus fluide, plus rapide quelquefois, mais un long texte comme le tien et sans le support n'aide vraiment pas et je ne parle pas des : ActiveWindow.ScrollColumn =xxx qui ajoute du temps au temps, les Select aussi (issu de l'enregistreur un peu trop bavard).

Jean-Pierre
 
Vote positif 0 Vote négatif
J

jcsellas

XLDnaute Nouveau
Re : Raccourcir la durée d'ouverture et d'enregistrement d'une macro ?

Merci Jean-Pierre pour cette réponse je vais laisser comme ca nikel
je suis entièrement d'accord avec toi ca va tjs plus vite que de la faire à la mano y a pas photo mais on sais jamais étant donnée que je suis débutant il y aurai pu avoir un remede miracle
meme si excel et notemment vba est deja le meilleur remede qui puisse exister

en tous cas je féllicite toutes les personnes qui ont créer le site et tous les utilisateurs de ce site car il est d'un grand secours et une grande école du vba

merci à toi JP et à tout le monde
 
Vote positif 0 Vote négatif
C

Compte Supprimé 979

Guest
Re : Raccourcir la durée d'ouverture et d'enregistrement d'une macro ?

Bonjour JP
Bonjour Jcsellas ;)

Je trouve que tu abandonnes plutôt vite :rolleyes:

Il y a pleins de choses à corriger dans ton code pour accélerer l'exécution.

En premier tu peux figer la mise à jour de l'écran, par
Code: 
application.ScreenUpdating = False
A la fin de ton code il suffit alors de ré-activer l'écran
Code: 
application.ScreenUpdating = True

Ensuite comme le dis JP, tu n'es pas obligé de faire des 'Select' pour mettre une valeur dans une cellule
Code: 
Sheets("Date").Select
Range("C11").Select
ActiveCell.FormulaR1C1 = InputBox("Veuillez entrer la date de fin, de la dernière période de prévision d'encaissement sous forme MM/JJ/AAAA")
Peut être remplacé par
Code: 
  Sheets("Date").Range("C11").FormulaR1C1 = InputBox("Veuillez entrer la date de fin, de la dernière période de prévision d'encaissement sous forme MM/JJ/AAAA")

Les lignes suivantes sont à supprimer
Code: 
ActiveWindow.ScrollColumn = 15
  ActiveWindow.ScrollColumn = 14
  ActiveWindow.ScrollColumn = 13
  ActiveWindow.ScrollColumn = 12
  ActiveWindow.ScrollColumn = 11
  ActiveWindow.ScrollColumn = 9
  ActiveWindow.ScrollColumn = 7
  ActiveWindow.ScrollColumn = 5
  ActiveWindow.ScrollColumn = 4
  ActiveWindow.ScrollColumn = 3

Et d'autres optimisations à faire ;)

Voilà A+
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
2 K
fanou06
F
R
  • Question
XL 2016 Rendre plus lisible un code VBA
2
Réponses
23
Affichages
1 K
TooFatBoy
TooFatBoy
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
411
gwenn49
G
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
627
Kevin38
K
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
315
robpellan52
R
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
308
vgendron
vgendron
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
239
Francky79
F
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
587
mouchtre
mouchtre
Z
  • Question
Microsoft 365 Ajouter une étiquette de confidentialité via macro
Réponses
4
Affichages
1 K
onobyone
O
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne

Membres actuellement en ligne

12 membres et 92 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 576
Messages
2 089 864
Membres
104 294
dernier inscrit
BByd