vitesse execution d'un code

[steve]

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

 

[Sylvain]

oups pas vu l'autre fil

Message édité par: Sylvain, à: 30/05/2006 11:15