Test de repertoire existant avant sauvegarde

[jlp035]

Bonjour,
je me permets de vous envoyer ce petit morceau de programme car essaye desesperement de le faire fonctionner .
Actuellement si chemin existe bien je n'ai pas de probléme pour copier le fichier.
Si le chemin n'existe pas le programme plante..
Je souhaite que si le chemin n'existe pas ou me propose de creer le chemin et ensuite de sauvegarder le fichier dans le repertoire creer.

Merci par avance pour vos solutions.

Sub CopieFeuilleDocuments()
      '
  Sheets("Chemins").Visible = True
  Sheets("Chemins").Select
  Crd = Range("B8") ' Chemin du repertoire Documents
  Fic = Range("B3") ' Fichier logiciel
   '
  Sheets("Documents").Select
  Soc = Range("O11") ' Nom Sociètè
  The = Range("B21") ' Thème
   '
   If Dir$(Crd) = "" Then
   ' copie de la zone à recopier
   Range("A56").Select
   Sheets("Documents").Select
   Sheets("Documents").Copy
   ' Cases à vider
   'Range("Y1:AA5").Select
   'Range("Y5").Activate
   'Selection.ClearContents
   ' Chemin du fichier copier
   Std = Crd & "\" & Soc & "  " & Format(Date, "yyyy_mm_dd") & "  " & Format(Time, "hh_mm") & "  " & The & ".xls"
   ActiveWorkbook.SaveAs Filename:=Std
   MsgBox "la feuille à ètè copièe dans le fichier documents destinataires:" & vbCrLf & Std
   ActiveWorkbook.Close
     Else
   MsgBox " Le fichier :" & " " & Crd & vbCrLf & " est introuvable ?.." & vbCrLf & vbCrLf & " Vérifier le chemin du fichier  :" & "  Documents du destinataire."
   MsgBox " Voulez vous rechercher le fichier", vbYesNo
   enregistrersous
     End If
    'Sheets("Chemins").Visible = False
    Windows(Fic).Activate
    Sheets("Documents").Select
    ActiveWindow.SmallScroll Down:=-35
  End Sub

 

[Jacou]

Re : Test de repertoire existant avant sauvegarde

Bonjour,
peut-être en utilisant l'instruction "On Error Resume Next" avant l'instruction "

ActiveWorkbook.SaveAs Filename:=Std" et en gérant les codes erreur derrière​

 

[Pierrot93]

Re : Test de repertoire existant avant sauvegarde

Bonjour,

pour vérifier qu'un dossier existe :

Dim c As String
c = "C:\Users\MesDocuments\Excel"
If Dir(c, vbDirectory) = "" Then
    MsgBox "dossier inéxistant"
Else
    MsgBox "existe"
End If

bonne soirée
@+

 

[Staple1600]

Re : Test de repertoire existant avant sauvegarde

Bonsoir à tous

Pareil que Pierrot93 mais différemment et avec une faute de français en bonus

Sub a()
Dim c As String
c = "C:\Users\MesDocuments\Excel"
MsgBox "Le dossier " & c & " existe " & IIf(Dir(c, 16) = vbNullString, " pas.", ".")
End Sub