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.
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.
Code:
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