Enregister un Fichier à l'aide d'une macro

[jonathan]

Bonjour à Tous,

Je souhaite enregister un fichier à l'aide d'une macro. Le Nom de mon fichier fait appel à une cellule excel.

Marci pour votre aide :sick:

 

[Pierre]

Salut Jonathan

Voici une macro qui je pense repondra à ta question. Celle-ci verifie la presence du repertoire cible et le cree au cas où il n'existerait pas et enregistre le fichier suivant le nom donnée


Sub Enreistrement ()

Dim TheFullPath As String
Dim MyName As String
Dim Nom_Fichier As String
Dim Nom_Fichier1 As String
Dim Fich_Sauv As String


Nom_Fichier = Range('Nom_fich')
Ch_Fichier = Range('Ch_fichier')
Division = Range('Division')

Nom_Fichier1 = Nom_Fichier + '.xls'

Fich_Sauv = Ch_Fichier + Nom_Fichier1


'Test de l'existance du Repertoire
If (MyName = Dir(Ch_Fichier, vbDirectory)) = vbEmpty Then
MsgBox 'Le repertoire ' & Chr(34) & Ch_Fichier & Chr(34) & ' existe bien!'
Else
'Creation du repetoires de sauvegarde de ce fichier
CheckingMakingDir
End If

'Test de l'existance du Fichier
If Dir(Fich_Sauv, vbNormal Or vbReadOnly Or vbArchive) = '' Then
'Enregistrement de ce fichier dans le repertoire créée
Enregistrement_Fichier
Else
Reponse = MsgBox('Le Fichier ' & Chr(34) & Nom_Fichier1 & Chr(34) & ' existe deja voulez vous le sauvegarder?', vbYesNo)
If Reponse = vbYes Then
ActiveWorkbook.Save
Else
End If
End If
Else
End If
End Sub

Sub CheckingMakingDir()
Dim TheFullPath As String
Dim TheSplitedPath As Variant
Dim i As Byte, NbRep As Byte
Dim ThePath As String

TheFullPath = Range('Ch_Fichier')
TheSplitedPath = Split(TheFullPath, '\\')

NbRep = UBound(TheSplitedPath)
For i = 0 To NbRep
ThePath = ThePath & TheSplitedPath(i) & '\\'
MakingDir ThePath
Next
End Sub

Sub MakingDir(ThePath As String)
On Error GoTo TheEnd
MkDir ThePath
TheEnd:
End Sub

Sub Enregistrement_Fichier()

Dim Ch_Fichier As String
Dim Ch_Fichier1 As String
Dim Nom_Fichier As String
Dim Nom_Fichier1 As String
Dim Fich_Sauv As String


Nom_Fichier = Range('Nom_fich')
Ch_Fichier = Range('Ch_fichier')

Nom_Fichier1 = Nom_Fichier + '.xls'

Fich_Sauv = Ch_Fichier + Nom_Fichier1

ActiveWorkbook.SaveAs Filename:=Fich_Sauv, FileFormat:=xlNormal, Password:='', WriteResPassword:='', _
ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

En esperant avoir repondu à ton attente
Pierre

 

[jonathan]

Salut Pierre,

La macro que je dois executer doit copier deux onglets dans un nouveau Classeur, l'enregistrer puis fermer mon fichier original & ma copie. Le Nom de monfichier copie correspond à une cellule de mon fichier original

 

[Pierre]

Regarde ce fichier et dit moi s'il correspond à ton attente

sur le coup de fermeture d'Excel je ne peux faire mieux.

@+
Pierre [file name=Test_20050627131819.zip size=12866]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Test_20050627131819.zip[/file]