Repertoire et fichier

Bonjour à tous,

Je bloque depuis 2 jours sur une foction en vba.

Dans une macro, je crée un document word en applicant une fusion entre un document type et des données qui se trouvent dans un fichier excel. Lorsque je sauve le document, la macro lui assigne le nom qui se trouve dans le champ B2 et cela foctionne à merveille.

Maintenant ce que j'aurais souhaité faire, c'est vérifier qu'un répertoire de même nom que le champ B2 existe et réaliser la sauvegarde du fichier dans ce répertoire et si le répertoire n'existe pas, le créer puis faire la sauvegarde dedans.

Je joins un morceau du code vba.

Merci d'avance pour votre aide.

Bonjour,

Je te poste ton code avec la modif :

Private Sub Creerdoc()

    Dim AAA As String, BBB As String
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim Fso As Object
    Dim Dossier As String

    Application.Cursor = xlWait       'affiche le sablier
'    WaitBox.Show vbModeless           'affiche la waitbox mais continu le traitement
'    WaitBox.Repaint                   'raffraichit le contenu affiché sinon on a une boite blanche vide

   'placer ici votre traitement...

    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")

    'construit le chemin
    Dossier = ActiveWorkbook.Path & "\" & ActiveSheet.Range("B2")

    'création du dossier si il n'existe pas
    If Fso.FolderExists(Dossier) = False Then

        Fso.CreateFolder Dossier

    End If

    AAA = ActiveWorkbook.Path & "\TEST.docx"
    BBB = Dossier & "\" & ActiveSheet.Range("B2").Text & ".docx"

    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(AAA, ReadOnly:=False)

    With WordApp
        .Visible = False

        .Selection.GoTo What:=wdGoToBookmark, Name:="Nom_Enfant"
        .Selection.TypeText Text:=ActiveSheet().Range("CB75").Value
        .Selection.GoTo What:=wdGoToBookmark, Name:="Prénom_Enfant"
        .Selection.TypeText Text:=ActiveSheet().Range("CB76").Value
        .Selection.GoTo What:=wdGoToBookmark, Name:="Né_Le_Jour"
        .Selection.TypeText Text:=ActiveSheet().Range("CB112").Value
        .Selection.GoTo What:=wdGoToBookmark, Name:="Né_Le_Mois"
        .Selection.TypeText Text:=ActiveSheet().Range("CB113").Value
        .Selection.GoTo What:=wdGoToBookmark, Name:="Né_Le_Année"
        .Selection.TypeText Text:=ActiveSheet().Range("CB114").Value

    End With

    WordDoc.Application.ActiveDocument.SaveAs BBB
    ActiveSheet.Hyperlinks.Add Anchor:=Range(Zone), Address:=BBB, TextToDisplay:=Ref

    WaitBox.Hide  'masque la waitbox
   Application.Cursor = xlDefault 'remet le curseur par défaut

    MsgBox ("Le Contrat de : " & ActiveSheet().Range("B2").Text & ".docx vient d'être créé sous Word"), vbInformation

    WordApp.Documents.Open (BBB)
    WordDoc.Application.Activate

'   WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing

End Sub

Hervé.

Merci Mille fois Hervé, C'est exactement ce qu'il me fallait et cela fonctionne très bien.

A bientôt