Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

vitesse execution d'un code

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion steve
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
S

steve

Guest
bonsoir
Comment puis je augmenté la vitesse de ce code

Merci d'avance

Sub ListerFichier1988()


Dim Direction As String
Dim Chw As String
Dim s As Byte
Dim p As Byte
Dim lig As Byte
Dim nb As Byte
Dim ann As Byte
Dim Trouve As Byte
nb = Sheets('BASES').Range('h4').Value
ann = Sheets('BASES').Range('a102').Value
For p = ann To nb
Range('BASES!A107') = p




Range('K3').ClearContents
Range('f7:k300').ClearContents
Direction = Sheets('BASES').Range('e1').Value
lig = 7
Cells(lig, 9) = 'Chemin fichier'
Cells(lig, 10) = 'Taille'
Cells(lig, 11) = 'Date/Heure'
Range('i7:k7').Font.Bold = True
lig = lig + 1


'Application.ScreenUpdating = False
With Application
.ScreenUpdating = False

End With

On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Direction
.Filename = '*.' & .xls
.SearchSubFolders = True
.Execute

For Trouve = 1 To .FoundFiles.Count

Cells(lig, 9) = .FoundFiles(Trouve)
Cells(lig, 10) = FileLen(.FoundFiles(Trouve))
Cells(lig, 11) = FileDateTime(.FoundFiles(Trouve))

lig = lig + 1
Next Trouve
End With

Range('I8:I300').Select
Selection.TextToColumns Destination:=Range('F8'), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(29, 1))

' Range('F8:F300').Select
' Selection.TextToColumns Destination:=Range('G8'), DataType:=xlDelimited, _
' TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
' Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
':=Array(Array(1, 9), Array(2, 1), Array(3, 9))



For s = 8 To Range('f300').End(xlUp).Row
If Right(Range('f' & s), 4) = '.xls' Then Range('g' & s) = Left(Range('f' & s), Len(Range('f' & s)) - 8)
Next













Range('G8').Select
'Application.ScreenUpdating = False
Range('A10').Select
Chw = Sheets('BASES').Cells(1, 14)
Workbooks.Open Filename:=(Chw), UpdateLinks:=0


Dim x As Byte
Dim y As Byte
Dim r As Byte
Dim Chr As String
Dim Chf As String
Dim Chj As String
Dim Chu As String
Dim Chz As String
'chz= analyse global
'chr et chu = zodiac
'chz= analyse global
Windows('TRANSFERT.xls').Activate

y = Range('BASES!g6').Value
For r = 8 To y
Chr = Sheets('BASES').Cells(r, 9)
Chu = Sheets('BASES').Cells(r, 6)
Chz = Sheets('BASES').Cells(1, 16)
Workbooks.Open Filename:=(Chr)

For x = 1 To 4
Windows(Chz).Activate
Chj = Range('Brevetstat!cc1').Value
Chf = Range('Brevetstat! ca1').Value
'copie % et annee et actualise
Windows('TRANSFERT.xls').Activate
Sheets('BASES').Activate
Cells(x, 2).Copy
Windows(Chu).Activate
Sheets('accueil').Activate
'% de baisse ou de hausse
Range('D1').PasteSpecial xlPasteValues
Application.CutCopyMode = False
Windows('TRANSFERT.xls').Activate
Sheets('BASES').Activate

' peut etre errereur
Cells(x, 3).Copy
Range('b8').PasteSpecial xlPasteValues
Application.CutCopyMode = False
Windows(Chu).Activate

''''Application.Run 'TRANSFERT.xls!ActualiserTCD'
Workbooks('TRANSFERT.xls').Worksheets('BASES').Range('A10😀26').Copy Destination:=Workbooks(Chu).Worksheets('accueil').Range('AE3')
Application.CutCopyMode = False
Windows('TRANSFERT.XLS').Activate
Sheets('BASES').Activate
Range('A29😀35').Copy
Windows(Chu).Activate
Sheets('accueil').Activate
'annee verticale

Range('G1').PasteSpecial xlPasteValues
Application.CutCopyMode = False
Windows('TRANSFERT.XLS').Activate
Range('A37:B60').Copy
Windows(Chu).Activate
Sheets('ANNEE').Activate
'annee horizontale

Range('A1').PasteSpecial xlPasteValues
Application.CutCopyMode = False
Windows('TRANSFERT.XLS').Activate

'mois choix
Range('H5').Copy
Windows(Chu).Activate
Sheets('accueil').Activate
Range('N5').PasteSpecial xlPasteValues

Windows('TRANSFERT.XLS').Activate

'annee choix
' Range('b8').Copy
'Windows(Chu).Activate
'Sheets('accueil').Select
'Range('o5').PasteSpecial xlPasteValues


Workbooks(Chz).Worksheets(Chf).Range('A1:Z73') = Workbooks(Chu).Worksheets('liason').Range('A1:Z73').Value

Application.CutCopyMode = False
Windows(Chu).Activate
Sheets('MOIS 12').Activate
Range('AZ25').Activate
Selection.ClearContents
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
Range('AA5:AM7').Copy
Windows(Chz).Activate
Sheets('Moisstat').Activate
Cells(Chj, 5).Activate
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
Windows('TRANSFERT.XLS').Activate
Sheets('BASES').Activate
Range(Cells(x, 2), Cells(x, 3)).Copy
Windows(Chz).Activate
Sheets('Moisstat').Activate
Cells(Chj, 3).Activate
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
Windows('TRANSFERT.XLS').Activate
Sheets('BASES').Activate
Windows(Chu).Activate
Sheets('lunebrev').Activate
Range('AZ25').Activate
Selection.ClearContents
Application.CutCopyMode = False
Range('AA5:CU7').Copy
Windows(Chz).Activate
Sheets('Brevetstat').Activate
Cells(Chj, 5).Activate
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
Windows('TRANSFERT.XLS').Activate
Sheets('BASES').Activate
Range(Cells(x, 2), Cells(x, 3)).Copy
Windows(Chz).Activate
Sheets('Brevetstat').Activate
Cells(Chj, 3).Activate
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER

'copie % et annee et actualise
Windows(Chu).Activate
'''''''''''''''''''''''''Application.Run 'TRANSFERT.xls!ActualiserTCD'
Next
Windows(Chu).Activate
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
ActiveWorkbook.Saved = True 'sauve sans enregistrer
' ActiveWorkbook.Save 'sauve en enregistrant
ActiveWorkbook.Close
Windows('TRANSFERT.xls').Activate
Next
Windows(Chz).Activate
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
With Application
.ScreenUpdating = True
End With
'Application.ScreenUpdating = True


End Sub
 
Trier par date Trier par votes
Bonsoir le forum, bonsoir steve,
En supprimant tout ce qui est select, puis en lisant ton code, on s'appercois que parfois tu 'active' une feuille, puis une autre sans avoir rien fait entre les deux, d'autre part tu appel d'autres macro qui elles aussi sont certainement très lourdes.
sans rentrer dans le détail, et en faisant déjà ça, tu devrais légèrement amèliorer ton usine à gaz.......
mais pour être plus efficace, il faudrait avoir le reste des autres macros.




fait que chaque heure de ta vie soie un souvenir pour demain.
 
Vote positif 0 Vote négatif
re,
et plutot que de passer par des .copy, les .value sont plus rapides et plus sur!!!
je continu à plancher sur ton usine à gaz........
un petit classeur aiderait bien à trouver ta solution !!!!

fait que chaque heure de ta vie soie un souvenir pour demain
 
Vote positif 0 Vote négatif
Re le forum, steve,
j'ai un peu raccourci ta macro,
elle doit te fournir le même résultat.
je me réserve le droit de m'être trompé partant du principe que je n'avais pas de classeur exemple pour tester !!!
Sub ListerFichier1988()


Dim Direction As String
Dim Chw As String
Dim s As Byte
Dim p As Byte
Dim lig As Byte
Dim nb As Byte
Dim ann As Byte
Dim Trouve As Byte
nb = Sheets('BASES').Range('h4').Value
ann = Sheets('BASES').Range('a102').Value
For p = ann To nb
Range('BASES!A107') = p




Range('K3').ClearContents
Range('f7:k300').ClearContents
Direction = Sheets('BASES').Range('e1').Value
lig = 7
Cells(lig, 9) = 'Chemin fichier'
Cells(lig, 10) = 'Taille'
Cells(lig, 11) = 'Date/Heure'
Range('i7:k7').Font.Bold = True
lig = lig + 1


'Application.ScreenUpdating = False
With Application
.ScreenUpdating = False

End With

On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Direction
.Filename = '*.' & .xls
.SearchSubFolders = True
.Execute

For Trouve = 1 To .FoundFiles.Count

Cells(lig, 9) = .FoundFiles(Trouve)
Cells(lig, 10) = FileLen(.FoundFiles(Trouve))
Cells(lig, 11) = FileDateTime(.FoundFiles(Trouve))

lig = lig + 1
Next Trouve
End With

Range('I8:I300').TextToColumns Destination:=Range('F8'), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(29, 1))

' Range('F8:F300').Select
' Selection.TextToColumns Destination:=Range('G8'), DataType:=xlDelimited, _
' TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
' Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
':=Array(Array(1, 9), Array(2, 1), Array(3, 9))



For s = 8 To Range('f300').End(xlUp).Row
If Right(Range('f' & s), 4) = '.xls' Then Range('g' & s) = Left(Range('f' & s), Len(Range('f' & s)) - 8)
Next


Chw = Sheets('BASES').Cells(1, 14)
Workbooks.Open Filename:=(Chw), UpdateLinks:=0


Dim x As Byte
Dim y As Byte
Dim r As Byte
Dim Chr As String
Dim Chf As String
Dim Chj As String
Dim Chu As String
Dim Chz As String
'chz= analyse global
'chr et chu = zodiac
'chz= analyse global
Windows('TRANSFERT.xls').Activate

y = Range('BASES!g6').Value
For r = 8 To y
Chr = Sheets('BASES').Cells(r, 9)
Chu = Sheets('BASES').Cells(r, 6)
Chz = Sheets('BASES').Cells(1, 16)
Workbooks.Open Filename:=(Chr)

For x = 1 To 4
Windows(Chz).Activate
Chj = Range('Brevetstat!cc1').Value
Chf = Range('Brevetstat! ca1').Value
'copie % et annee et actualise

Windows(Chu).Sheets('accueil').Range('D1').value=Windows('TRANSFERT.xls').Sheets('BASES').Cells(x, 2).value

Windows('TRANSFERT.xls').Sheets('BASES')Range('b8').Values=Windows('TRANSFERT.xls').Sheets('BASES').Cells(x, 3).value


Windows(Chu).Activate

''''Application.Run 'TRANSFERT.xls!ActualiserTCD'
Workbooks('TRANSFERT.xls').Worksheets('BASES').Range('A10😀26').Copy Destination:=Workbooks(Chu).Worksheets('accueil').Range('AE3')
Application.CutCopyMode = False
Windows(Chu).Sheets('accueil').Range('G1').Value=Windows('TRANSFERT.XLS').Sheets('BASES').Range('A29😀35').value



Windows(Chu).Sheets('ANNEE').Range('A1').Value=Windows('TRANSFERT.XLS').Range('A37:B60').value


Windows(Chu).Sheets('accueil').Range('N5').Value=Windows('TRANSFERT.XLS').Range('H5').value


Windows('TRANSFERT.XLS').Range('b8').value
'Windows(Chu).Activate
'Sheets('accueil').Select
'Range('o5').PasteSpecial xlPasteValues


Workbooks(Chz).Worksheets(Chf).Range('A1:Z73') = Workbooks(Chu).Worksheets('liason').Range('A1:Z73').Value

Application.CutCopyMode = False
Windows(Chu).Sheets('MOIS 12').Range('AZ25').ClearContents
Application.CutCopyMode = False 'VIDE LE PRESSE PAPIER
Windows(Chz).sheets('Moisstat').Cells(Chj, 5).value=Windows(Chu).Sheets('MOIS 12').Range('AA5:AM7').value


Windows(Chz).Sheets('Moisstat').Cells(Chj, 3).value=Windows('TRANSFERT.XLS').Sheets('BASES').Range(Cells(x, 2), Cells(x, 3)).value



Windows(Chu).Sheets('lunebrev').Range('AZ25').ClearContents

Windows(Chz).Sheets('Brevetstat').Cells(Chj, 5).value=Windows(Chu).Sheets('lunebrev').Range('AA5:CU7').value


Windows(Chz).Sheets('Brevetstat').Cells(Chj, 3).value=Windows('TRANSFERT.XLS').Sheets('BASES').Range(Cells(x, 2), Cells(x, 3)).value




ActiveWorkbook.Saved = True 'sauve sans enregistrer

ActiveWorkbook.Close


Windows(Chz).Activate

ActiveWorkbook.Save
ActiveWorkbook.Close
Next

Application.ScreenUpdating = True


End Sub


bon courage. @ plus


fait que chaque heure de ta vie soit un souvenir pour demain
 
Vote positif 0 Vote négatif
Bonjour,


une idée (déjà dite) serait de remplacer quand c'est possible les copier collage spécial valeur simplement par exemple par :

range('a1:b5').value=range('c1:d5').value

Une autre chose, mais je ne sais pas si ça correspond à ton document, c'est le mode de calcul. Si on est en mode de calcul automatique, chaque changement de valeur on va perdre un temps de recalcul. On peut utiliser
application.Calculation=xlCalculationManual
puis calculate quand on en a besoin
et enfin remettre application.Calculation=xlCalculationAutomatic
à la fin.
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
809
M@xu3L
M
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
390
farid
F
  • 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
1 K
mouchtre
W
  • Question Question
XL 2021 Boucle copier-coller par nom d'en-tête de colonnes
Réponses
10
Affichages
773
whiteshark
W
C
  • Question Question
Autres bug sur une procédure avec textbox contenant un code barre
2
Réponses
15
Affichages
2 K
TooFatBoy
L
  • Question Question
XL 2016 correction d'un code VBA
Réponses
7
Affichages
655
LAPIN-53
L
X
  • Question Question
XL 2016 Souci copier/coller avec un filtre.
2 3 4
Réponses
55
Affichages
5 K
Xender
X
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
3 K
AtTheOne
K
  • Question Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
934
Kevin38
K
A
  • Question Question
Microsoft 365 Copier/coller un plusieurs lignes
Réponses
5
Affichages
865
LeSaintKebab
L
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
2 K
ERIC S
G
  • Question Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
763
guiyom
G
N
  • Résolu(e)
XL 2019 Aide macro on error resume
Réponses
3
Affichages
599
netparty
N
D
  • Question Question
XL 2019 Aide à la compréhension d'un code VBA
Réponses
4
Affichages
1 K
Dudu2
J
  • Question Question
Microsoft 365 Formules
Réponses
2
Affichages
721
jper
J
A
  • Question Question
XL 2019 Faire un filtre sur deux dates
Réponses
0
Affichages
714
A-F
A
S
  • Question Question
Microsoft 365 Exécuter macro après lancement hypertexte
Réponses
7
Affichages
933
job75
K
  • Résolu(e)
XL 2019 Copier Seulement les lignes affichée après un filtre de tableau
Réponses
9
Affichages
2 K
Kushi
K
A
  • Question Question
Microsoft 365 boucle macro pour importer des données
2
Réponses
16
Affichages
2 K
Arnaud Legay
A
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…