Copier classeur

[nextrevolution]

Bonjour le forum,

Je cherche à faire la copie d'un classeur en code VBA, j'ai essayé un code mais il me copie page par page vers un nouveau classeur.
J'aimerais copier le classeur entier et le coller à un endroit que je sélectionne dans l'arborescence de mes fichiers.

Je vous remercie d'avance pour vos réponses

 

[Bernard_XLD]

Re : Copier classeur

Bonjour

il vaut mieux utiliser une instruction savecopyas. Cette méthode enregistre une copie du classeur dans un fichier sans modifier le classeur ouvert en mémoire

ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"

Cordialement

 

[Bigfish]

Re : Copier classeur

Salut, Salut le forum,

et si la question etait copier le fichier sans l'ouvrir ?

Function DialogBox(Optional Root As String, Optional DialogTitle As String = "Selection du repertoire de destination...", Optional DialogType As MsoFileDialogType = msoFileDialogFolderPicker) As String
        With Application.FileDialog(DialogType)
            .AllowMultiSelect = False
            .Title = DialogTitle
            .InitialFileName = Root
            If .Show = -1 Then DialogBox = .SelectedItems(1)
        End With
End Function
Function CopierFichier(ByVal Fichier As String, ByVal RepertoireSource As String, ByVal RepertoireDeDestination As String, Optional OverWrite As Boolean = False)
    Dim fs As Object, f As Object, reponse As String
    
    If Not Right$(RepertoireSource, 1) = Application.PathSeparator Then RepertoireSource = RepertoireSource & Application.PathSeparator
    If Not Right$(RepertoireDeDestination, 1) = Application.PathSeparator Then RepertoireDeDestination = RepertoireDeDestination & Application.PathSeparator

    Set fs = CreateObject("Scripting.FileSystemObject")
    If OverWrite = True Then
        Set f = fs.getfile(RepertoireDeDestination & Fichier)
        If f.Attributes Mod 2 = 1 Then
            reponse = MsgBox("Le fichier '" & Fichier & "' du repertoire '" & RepertoireDeDestination & "' est en lecture seul! " & vbCrLf & _
                    "Voulez-vous quand même ecraser le fichier existant ?", vbExclamation + vbYesNo)
            If reponse = vbYes Then
                f.Attributes = f.Attributes - 1
            Else
                Exit Function
            End If
        End If
    End If
    fs.Copyfile RepertoireSource & Fichier, RepertoireDeDestination, OverWrite
End Function
Sub test()
    Dim MonFichier As String, NewRep As String, RepSource As String, reponse As VbMsgBoxResult

    MonFichier = DialogBox("C:\", "Selection du fichier à Copié...", msoFileDialogFilePicker)
    If MonFichier = "" Then Exit Sub
    RepSource = Replace(MonFichier, Dir(MonFichier), "")
    MonFichier = Dir(MonFichier)
    NewRep = DialogBox(RepSource)
    If NewRep = "" Then
        Exit Sub
    Else
     NewRep = NewRep & Application.PathSeparator
    End If
    If Not Dir(NewRep & Dir(MonFichier)) = "" Then
        reponse = MsgBox("Le fichier '" & MonFichier & "' existe déjà, dans le repertoire '" & _
                    NewRep & "' !" & vbCrLf & "Voulez-vous écraser le fichier '" & Dir(MonFichier) _
                    & "' ?", vbExclamation + vbYesNo)
        If reponse = vbYes Then
        
            CopierFichier MonFichier, RepSource, NewRep, True
        Else
            Exit Sub
        End If
    Else
        CopierFichier MonFichier, RepSource, NewRep
    End If
End Sub

on pourrait aussi utiliser des variables tableau et autoriser la multi selection pour copier plusieurs fichiers.

A+