Optimisation Copier Coller VBA

**ThomasVil** · 10/07/2018, 11h13

Bonjour on m'a informé que faire un copier coller ralentit de beaucoup le programme ainsi j'aimerai connaitre si possible une autre formule pour coller mais qui soit optimisé (ci dessous mon programme) Merci

Cordialement, Thomas

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub Macro1()
Dim azer As Variant
Dim NomFichier As Variant
Dim bool As Boolean
 
NomFichier = ThisWorkbook.Name
Set FL21 = Workbooks(NomFichier).Worksheets("Grille Produits 2018 liaison")
 
bool = VerificationFichierOuvert("offreglobale.xlsm")
 
If bool = True Then
MsgBox "OffreGlobal déja ouvert"
 
Else
MsgBox "OffreGlobal pas ouvert"
Workbooks.Open ("C:\....chemin")
 
End If
Set FL12 = Workbooks("offreglobale.xlsm").Worksheets("MillesFeuilles")
With FL12
Columns("A:U").Select
Selection.Copy
End With
 
 
With FL21
 
Cells.Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
 
 
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
 
End Sub

**Thautheme** · 10/07/2018, 15h06

Bonjour Thomas, bonjour le forum,

Peut-être comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Macro1()
Dim CS As Workbook
Dim OS As Worksheet
Dim CD As Workbook
Dim OD As Worksheet
 
Set CS = ThisWorkbook
Set OS = CS.Worksheets("Grille Produits 2018 liaison")
On Error Resume Next
Set CD = Workbooks("offreglobale.xlsm")
If Err <> 0 Then
    Set CD = Workbooks.Open("C:\....chemin\offreglobale.xlsm")
End If
On Error GoTo 0
Set OD = CD.Worksheets("MillesFeuilles")
OS.Columns("A:U").Copy
OD.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
OD.Range("A1").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
OD.Range("A1").Select
End Sub