Code VBA pour vérifier si un fichier existe avant sauvegarde

Le 12/03/2018 à 17:00

Bonjour le forum,

En me servant de spots similaires j'ai écrit un code pour copier dans un nouveau classeur des feuilles d'un autre classeur.

Je voudrais ouvrir une boîte de dialogue, pour avertir si le nom donné pour la sauvegarde du nouveau classeur existe déjà.

Le choix du répertoire où se fait la sauvegarde n'est pas imposé.

Voici le code que j'ai utilisé pour créer et sauvegarder le nouveau classeur :

Sub Extraire_Sortie()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim a, e, Rep As Integer, Repertoire As String, Nomsortie As String

If Range("M6") = 0 And Range("M6") = "" Then[attachment=0]Exemple.xlsm[/attachment]
    Rep = MsgBox(" Le nom du fichier pour la sauvegarde du fichier Excel joint au compte-rendu de la sortie n'a pas été saisi dans la cellule M6. ")

Else

    MsgBox ("Indiquer le repertoire ou sera enregistré le fichier")
    Repertoire = ChoixDossier
    Application.DisplayAlerts = False

    Nomsortie = Sheets("Sortie").Range("M6")

    a = Array("Partenaires des Postulants", "Sorties 2018", "Partenaires")
        With Workbooks.Add(xlWBATWorksheet)
            For Each e In a
                ThisWorkbook.Sheets(e).Copy After:=.Sheets(.Sheets.Count)
            Next
            .Sheets(1).Delete
            .Sheets(1).Select
            .SaveAs Repertoire & "\" & Nomsortie
            .Close
        End With
End If

Application.ScreenUpdating = True

End Sub

Et le code pour le choix du répertoire :

Function ChoixDossier()

If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count = 1 Then
            ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
    End With
Else
    ChoixDossier = InputBox("Répertoire?")
End If

End Function

Ce que je cherche, c'est qu'avant de faire la sauvegarde, il y ait un message indiquant que le fichier existe déjà, et si on veut écraser le fichier existant.

Merci d'avance pour votre aide.

120exemple.xlsm (21.76 Ko)
Le 12/03/2018 à 18:24

bonjour,

une proposition

Sub Extraire_Sortie()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim a, e, Rep As Integer, Repertoire As String, Nomsortie As String

    If Range("M6") = 0 And Range("M6") = "" Then
        Rep = MsgBox(" Le nom du fichier pour la sauvegarde du fichier Excel joint au compte-rendu de la sortie n'a pas été saisi dans la cellule M6. ")

    Else

        MsgBox ("Indiquer le repertoire ou sera enregistré le fichier")
        Repertoire = ChoixDossier
        Application.DisplayAlerts = False

        Nomsortie = Sheets("Sortie").Range("M6")
        If Dir(Repertoire & "\" & Nomsortie) <> "" Then
            Rep = MsgBox("ce fichier existe déjà, ok pour le remplacer ?", vbYesNo)

            If Rep = vbYes Then

                a = Array("Partenaires des Postulants", "Sorties 2018", "Partenaires")
                With Workbooks.Add(xlWBATWorksheet)
                    For Each e In a
                        ThisWorkbook.Sheets(e).Copy After:=.Sheets(.Sheets.Count)
                    Next
                    .Sheets(1).Delete
                    .Sheets(1).Select
                    .SaveAs Repertoire & "\" & Nomsortie
                    .Close
                End With
            End If

        End If
    End If

    Application.ScreenUpdating = True

End Sub
Le 12/03/2018 à 18:37

Une autre proposition:

Sub Extraire_Sortie()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim a, e, Rep As Integer, Repertoire As String, Nomsortie As String

If Range("M6") = 0 And Range("M6") = "" Then
    Rep = MsgBox(" Le nom du fichier pour la sauvegarde du fichier Excel joint au compte-rendu de la sortie n'a pas été saisi dans la cellule M6. ")

Else

    MsgBox ("Indiquer le repertoire ou sera enregistré le fichier")
    Repertoire = ChoixDossier
    Application.DisplayAlerts = False

    Nomsortie = Sheets("Sortie").Range("M6")

    a = Array("Partenaires des Postulants", "Sorties 2018", "Partenaires")
        With Workbooks.Add(xlWBATWorksheet)
            For Each e In a
                ThisWorkbook.Sheets(e).Copy After:=.Sheets(.Sheets.Count)
            Next
            .Sheets(1).Delete
            .Sheets(1).Select
            Dim sFile As String
            Dim lRep As Long
            Dim saveOK As Boolean

            sFile = Repertoire & "\" & Nomsortie
            If ExistsEXCEL(sFile) Then
                lRep = MsgBox("Le fichier '" & sFile & "' existe déjà!" & vbCrLf & vbCrLf _
                            & "Voulez-vous le remplacer?", vbExclamation + vbYesNo, "FICHIER EXISTANT")
                If lRep = vbYes Then
                    Dim oFS As Object
                    Set oFS = CreateObject("Scripting.FileSystemObject")

                    oFS.DeleteFile sFile, True
                    saveOK = True
                Else
                    saveOK = False
                End If
            Else
                saveOK = True
            End If

            If saveOK Then
                .SaveAs Repertoire & "\" & Nomsortie
            End If
            .Close
        End With
End If

Application.ScreenUpdating = True

End Sub

Avec la fonction :

Function ExistsEXCEL(zFile As String) As Boolean
    Dim oFS As Object
    Set oFS = CreateObject("Scripting.FileSystemObject")

    If oFS.FileExists(zFile) Then
        ExistsEXCEL = True
    Else
        ExistsEXCEL = False
    End If

    Set oFS = Nothing
End Function
Le 12/03/2018 à 19:10

Bonsoir GVIALLES,

Merci pour tes 2 réponses. J'ai collé des codes dans mon fichier, mais cela ne fonctionne pas.

Je pense que cela vient du code de la fonction concernant le choix du dossier :

Function ChoixDossier()

If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count = 1 Then
            ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
    End With
Else
    ChoixDossier = InputBox("Répertoire?")
End If

End Function

Mais mes connaissances en VBA sont très limitées et je ne trouve pas où est l'erreur.

as-tu une idée ?

Merci

Le 12/03/2018 à 19:13

bonsoir h2so4,

Désolé de t'avoir oublié dans ma réponse.

Comme indiqué, dans mon message précédent, je pense avoir une erreur au niveau de la fonction ChoixDossier.

As-tu une idée.

Merci.

Le 12/03/2018 à 19:46

rebonsoir,

je n'ai pas testé la proposition que j'avais faite, j'aurais dû le faire.

voici une correction

Sub Extraire_Sortie()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim a, e, Rep As Integer, Repertoire As String, Nomsortie As String

    If Range("M6") = 0 Or Range("M6") = "" Then
        Rep = MsgBox(" Le nom du fichier pour la sauvegarde du fichier Excel joint au compte-rendu de la sortie n'a pas été saisi dans la cellule M6. ")

    Else

        MsgBox ("Indiquer le repertoire ou sera enregistré le fichier")
        Repertoire = ChoixDossier
        Application.DisplayAlerts = False

        Nomsortie = Sheets("Sortie").Range("M6")
        Rep = vbYes
        If Dir(Repertoire & "\" & Nomsortie) <> "" Then
            Rep = MsgBox("ce fichier existe déjà, ok pour le remplacer ?", vbYesNo)
            End If
            If Rep = vbYes Then

                a = Array("Partenaires des Postulants", "Sorties 2018", "Partenaires")
                With Workbooks.Add(xlWBATWorksheet)
                    For Each e In a
                        ThisWorkbook.Sheets(e).Copy After:=.Sheets(.Sheets.Count)
                    Next
                    .Sheets(1).Delete
                    .Sheets(1).Select
                    .SaveAs Repertoire & "\" & Nomsortie
                    .Close
                End With
            End If

    End If

    Application.ScreenUpdating = True

End Sub
Le 12/03/2018 à 21:59

Bonsoir Sergio,

J'ai testé l'ensemble du code et n'ai pas trouvé l'erreur.

Peux-tu être plus précis sur l'erreur que tu rencontres? Code de l'erreur et ligne sur laquelle elle se produit...

Le 13/03/2018 à 07:09

Bonjour,

Voici ta fonction un peu modifié afin de ne pas avoir à utiliser l'InputBox pour les anciennes versions :

Function ChoixDossier()

    Dim Sh, Dos

    If Val(Application.Version) >= 10 Then

        With Application.FileDialog(msoFileDialogFolderPicker)

            .InitialFileName = ActiveWorkbook.Path & "\"
            ChoixDossier = IIf(.Show = -1, .SelectedItems(1), "")

        End With

    Else

        Set Sh = CreateObject("Shell.Application")
        Set Dos = Sh.BrowseForFolder(&H0&, "Répertoire.", &H4000)
        ChoixDossier = Dos.ParentFolder.ParseName(Dos.Title).Path & "\"

    End If

End Function
Le 13/03/2018 à 18:42

Bonsoir à tous,

Merci pour vos réponses, mais j'ai toujours un problème. Lorsque j'exécute la macro si un fichier créé porte le même nom qu'un fichier existant, je n'ai pas de message d'alerte et le fichier existant est écrasé.

Avez-vous une idée ?

Merci encore pour votre aide

Le 14/03/2018 à 12:22

Bonjour,

j'ai omis l'extension .xls* dans mon contrôle d'existence du fichier.

Sub Extraire_Sortie()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim a, e, Rep As Integer, Repertoire As String, Nomsortie As String

    If Range("M6") = 0 Or Range("M6") = "" Then
        Rep = MsgBox(" Le nom du fichier pour la sauvegarde du fichier Excel joint au compte-rendu de la sortie n'a pas été saisi dans la cellule M6. ")

    Else

        MsgBox ("Indiquer le repertoire ou sera enregistré le fichier")
        Repertoire = ChoixDossier
        Application.DisplayAlerts = False

        Nomsortie = Sheets("Sortie").Range("M6")
        Rep = vbYes
        Dim f

        If Dir(Repertoire & "\" & Nomsortie & ".xls*") <> "" Then
            Rep = MsgBox("ce fichier existe déjà, ok pour le remplacer ?", vbYesNo)
            End If
            If Rep = vbYes Then

                a = Array("Partenaires des Postulants", "Sorties 2018", "Partenaires")
                With Workbooks.Add(xlWBATWorksheet)
                    For Each e In a
                        ThisWorkbook.Sheets(e).Copy After:=.Sheets(.Sheets.Count)
                    Next
                    .Sheets(1).Delete
                    .Sheets(1).Select
                    .SaveAs Repertoire & "\" & Nomsortie
                    .Close
                End With
            End If

    End If

    Application.ScreenUpdating = True

End Sub
Le 14/03/2018 à 13:13

Bonjour h2so4,

Merci beaucoup pour ton aide.

Cela fonctionne très bien.

Très bonne journée.

Rechercher des sujets similaires à "code vba verifier fichier existe sauvegarde"