Raccourcis temps de traitement

Le 04/03/2020 à 17:14

Bonjour,

Si vous avez des idées pour réduire le temps de traitement du code ci-dessous:

Je suis preneuse ! Merci

Sub AllColleEtSauve()

Dim Cellule As Range, LaDate As String

Dim Stard As Single

Start = Timer

myMonth = Application.InputBox("MOIS")

For Each Cellule In Range("SERVICES")

LaDate = Format(Date, "YYYY-M-D")

Sheets("DETAILS 20VS19").Copy

Sheets.Add(Before:=Sheets("DETAILS 20VS19")).Name = "SYNTHESE"

ThisWorkbook.Sheets("Synthese").Range(Cellule.Value).Copy

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

False, Transpose:=False

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

False, Transpose:=False

Selection.PasteSpecial 8

ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").AutoFilter Field:=19, Criteria1:= _

Cellule.Value

ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").Copy

Sheets.Add(After:=Sheets("DETAILS 20VS19")).Name = "DONNEES 2019"

ActiveSheet.Paste

Sheets("DONNEES 2019").Range("A:M").Name = "DATA19"

Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotSelect "", xlDataAndLabel, True

Sheets("DETAILS 20VS19").PivotTables("TCD19").ChangePivotCache ActiveWorkbook.PivotCaches. _

Create(SourceType:=xlDatabase, SourceData:="=DATA19", Version:=6)

Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotCache.Refresh

Sheets("DETAILS 20VS19").PivotTables("TCD19").SaveData = True

Sheets("SYNTHESE").Select

ActiveWorkbook.SaveAs Filename:= _

"C:\" & myMonth & "e\" _

& Cellule.Value & " " & LaDate, _

FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Next Cellule

MsgBox "Le chemin de vos fichiers :

MsgBox "Durée du traitement: " & Timer - Start & " secondes"

End Sub

Le 05/03/2020 à 08:14

Salut saaku,

à tester

Sub AllColleEtSauve()

Dim Cellule As Range, LaDate As String, CalcState As Long, EventState As Boolean, PageBreakState As Boolean
Dim Stard As Single
Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

Start = Timer
myMonth = Application.InputBox("MOIS")
For Each Cellule In Range("SERVICES")
LaDate = Format(Date, "YYYY-M-D")
Sheets("DETAILS 20VS19").Copy
Sheets.Add(Before:=Sheets("DETAILS 20VS19")).Name = "SYNTHESE"
ThisWorkbook.Sheets("Synthese").Range(Cellule.Value).Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial 8
ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").AutoFilter Field:=19, Criteria1:= _
Cellule.Value
ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").Copy
Sheets.Add(After:=Sheets("DETAILS 20VS19")).Name = "DONNEES 2019"
ActiveSheet.Paste
Sheets("DONNEES 2019").Range("A:M").Name = "DATA19"
Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotSelect "", xlDataAndLabel, True
Sheets("DETAILS 20VS19").PivotTables("TCD19").ChangePivotCache ActiveWorkbook.PivotCaches. _
Create(SourceType:=xlDatabase, SourceData:="=DATA19", Version:=6)
Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotCache.Refresh
Sheets("DETAILS 20VS19").PivotTables("TCD19").SaveData = True
Sheets("SYNTHESE").Select
ActiveWorkbook.SaveAs Filename:= _
"C:\" & myMonth & "e\" _
& Cellule.Value & " " & LaDate, _
FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close

Next Cellule
MsgBox "Le chemin de vos fichiers :"
MsgBox "Durée du traitement: " & Timer - Start & " secondes"

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub

Bonne journée

Le 05/03/2020 à 10:40

Merci à toi,

Mais ça fait planter la boucle :/

Le 05/03/2020 à 10:44

et comme ca?

Sub AllColleEtSauve()

Dim Cellule As Range, LaDate As String
Dim Stard As Single
Application.ScreenUpdating = False

Start = Timer
myMonth = Application.InputBox("MOIS")
For Each Cellule In Range("SERVICES")
LaDate = Format(Date, "YYYY-M-D")
Sheets("DETAILS 20VS19").Copy
Sheets.Add(Before:=Sheets("DETAILS 20VS19")).Name = "SYNTHESE"
ThisWorkbook.Sheets("Synthese").Range(Cellule.Value).Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial 8
ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").AutoFilter Field:=19, Criteria1:= _
Cellule.Value
ThisWorkbook.Sheets("DONNEES 2019").Range("DATA19").Copy
Sheets.Add(After:=Sheets("DETAILS 20VS19")).Name = "DONNEES 2019"
ActiveSheet.Paste
Sheets("DONNEES 2019").Range("A:M").Name = "DATA19"
Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotSelect "", xlDataAndLabel, True
Sheets("DETAILS 20VS19").PivotTables("TCD19").ChangePivotCache ActiveWorkbook.PivotCaches. _
Create(SourceType:=xlDatabase, SourceData:="=DATA19", Version:=6)
Sheets("DETAILS 20VS19").PivotTables("TCD19").PivotCache.Refresh
Sheets("DETAILS 20VS19").PivotTables("TCD19").SaveData = True
Sheets("SYNTHESE").Select
ActiveWorkbook.SaveAs Filename:= _
"C:\" & myMonth & "e\" _
& Cellule.Value & " " & LaDate, _
FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close

Next Cellule
MsgBox "Le chemin de vos fichiers :"
MsgBox "Durée du traitement: " & Timer - Start & " secondes"

Application.ScreenUpdating = True
End Sub
Rechercher des sujets similaires à "raccourcis temps traitement"