Optimisation Code

Bonjour,

Je dois copier plusieurs cellule d'un classeur vers un autre avec l'option de collage 'Valeurs' J'ai créé ce code qui fonctionne mais n'est pas du tout optimiser.

une petite idée

Merci d'avance

Sub Enregistrement()
'fichier en cours
Dim Fichier_data As Workbook 'Fichier excel de commande
'Fichier de destination
Dim Fichier_Cible As Workbook 'Fichier Excel de destination
Dim Chemin_Fichier_Cible As String 'Chemin du fichier de destination

'Identifier chemin fichier SPPF
Chemin_Fichier_Cible = "E:\Postes Saisie\Commande.xlsm"

Set Fichier_data = ActiveWorkbook
Set Fichier_Cible = Application.Workbooks.Open(Chemin_Fichier_Cible) 'ouvrir le fichier pour la copie

' Copie Feuille
Fichier_data.Worksheets(3).Activate
Range("A6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy

Fichier_Cible.Worksheets(1).Activate
Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

' Copie Feuille "Bon cde"
Fichier_data.Worksheets(4).Activate
    Range("A15:AS36").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("A15").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Fichier_data.Worksheets(4).Activate
    Range("Z4:Z6").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("Z4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Fichier_data.Worksheets(4).Activate
    Range("AJ4:AJ5").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("AJ4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Fichier_data.Worksheets(4).Activate
    Range("AR37:AS40").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("AR37").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Fichier_data.Worksheets(4).Activate
    Range("AS41").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("AS41").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Fichier_data.Worksheets(4).Activate
    Range("AC10").Select
        Selection.Copy
    Fichier_Cible.Worksheets(2).Activate
    Range("AC10").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Sub

Bonjour,

Un essai :

Sub Enregistrement()

Dim Sh4 As Worksheet

Application.Workbooks.Open "E:\Postes Saisie\Commande.xlsm" 'ouvrir le fichier pour la copie
Set Sh4 = ThisWorkbook.Worksheets(4)

' Copie Feuille
ThisWorkbook.Worksheets(3).Range("A6").CurrentRegion.Copy
ActiveWorkbook.Worksheets(1).Range("A6").PasteSpecial Paste:=xlPasteValues

With ActiveWorkbook.Worksheets(2)
    ' Copie Feuille "Bon cde"
    .Range("A15:AS36").Value = Sh4.Range("A15:AS36").Value
    .Range("Z4:Z6").Value = Sh4.Range("Z4:Z6").Value
    .Range("AJ4:AJ5").Value = Sh4.Range("AJ4:AJ5").Value
    .Range("AR37:AS40").Value = Sh4.Range("AR37:AS40").Value
    .Range("AS41").Value = Sh4.Range("AS41").Value
    .Range("AC10").Value = Sh4.Range("AC10").Value
End With

End Sub

Le code fonctionne très bien.

Encore merci pour l'aide et la rapidité

Bonne journée

Romjé41 a écrit :

Le code fonctionne très bien.

Encore merci pour l'aide et la rapidité

Bonne journée

Merci du retour et pour la validation ! Bonne journée également.