Enregistrer un word en le nommant avec le texte d'un champs de tableau

Bonjour à tous,

Je viens encore faire appel à votre aide et vous remercie par avance.

Je souhaiterais ajouter dans la macro existante de mon fichier word, un peu de code afin de récupérer les valeurs de 2 cellules d'un tableau afin de les utiliser pour le nom du fichier et le sauvegarder.

Mon fichier est composé de 4 tableaux, je souhaite récupéré :

1/ la valeur du tableau nr 1, ligne 1 colonne 2 (Le nom);

2/ la valeur du tableau nr 1, ligne 2 colonne 2 (Le prénom).

Voici mon tableau :

Lorsque que je clic sur le bouton export info, je souhaiterais que le fichier soit enregistré dans le dossier courant (d:\consultations\) au format suivant :

- nom en majuscule suivi d'un espace et du prénom avec la première lettre en majuscule, voici un exemple :

LEJEUNE Geoffrey.docm

Voici le code déjà présent dans le fichier Word, celui-ci permet d'exporter le nom du médecin traitant et des autres spécialistes dans un fichier XLS.

Public Const FichierCentral = "\BDD.xlsx"
Public Const TtkUp = -4162 ' valeur de xlUp

Sub Vers_Excel()
Dim XlApp As Object, XlDoc As Object
Dim NDF As String, lg As Long

NDF = ActiveDocument.Path & FichierCentral
Set XlApp = CreateObject("Excel.application")
Set XlDoc = XlApp.Workbooks.Open(NDF, ReadOnly:=False)
With XlApp
.Visible = False
With .ActiveWorkbook.Sheets("Feuil1")
lg = .Cells(.Rows.Count, 1).End(TtkUp).Row + 1
.Range("A" & lg).Value = Info_A_recuperer("Médecin traitant")
.Range("B" & lg).Value = Info_A_recuperer("Autre.s spécialiste")
End With
End With
XlDoc.Save
XlDoc.Close
XlApp.Application.Quit
Set XlDoc = Nothing
Set XlApp = Nothing
End Sub

Function Info_A_recuperer(Info As String) As String
Dim i As Byte, S As String

With ThisDocument.Tables(1)
For i = 1 To .Rows.Count
If .Cell(i, 1).Range.Text Like "*" & Info & "*" Then
S = .Cell(i, 2).Range.Text
Info_A_recuperer = Left(S, Len(S) - 1)
End If
Next i
End With
End Function

Un tout GRAND merci par avance et meilleurs vœux pour cette nouvelle année.

Bien à vous,

Geoffrey

Bonjour,

A tester :

Option Explicit

Sub SauvegardeDossierPatient()

Dim PatientNom As String, PatientPrenom As String, Repertoire As String

    With ActiveDocument

         Repertoire = .Path & "\"  ' A adapter
         PatientNom = Info_A_recuperer2(ActiveDocument, "NOM", "Nom")
         PatientPrenom = Info_A_recuperer2(ActiveDocument, "Prénom", "Prénom")

         .SaveAs FileName:=Repertoire & PatientNom & " " & PatientPrenom, fileformat:=wdFormatXMLDocumentMacroEnabled

    End With

End Sub

Function Info_A_recuperer2(ByVal DocEnCours As Document, ByVal Info As String, ByVal TypeChaine As String) As String

Dim I As Integer, J As Integer
Dim Chaine As String, Chaine2 As String
Dim PrenomCompose As Boolean

    With DocEnCours.Tables(1)
         For I = 1 To .Rows.Count
             If InStr(1, .Cell(I, 1).Range.Text, Info, vbTextCompare) > 0 Then
                Chaine = Left(.Cell(I, 2).Range.Text, Len(.Cell(I, 2).Range.Text) - 2)
                Select Case TypeChaine
                       Case "Nom"
                            Info_A_recuperer2 = UCase(Chaine)
                       Case "Prénom"
                            Chaine2 = LCase(Chaine)
                            Info_A_recuperer2 = UCase(Mid(Chaine2, 1, 1))
                            PrenomCompose = False

                            For J = 2 To Len(Chaine2)
                                Select Case Mid(Chaine2, J, 1)
                                       Case " ", "-"
                                           PrenomCompose = True
                                           Info_A_recuperer2 = Info_A_recuperer2 & "-"
                                       Case Else
                                           If PrenomCompose = True Then
                                              Info_A_recuperer2 = Info_A_recuperer2 & UCase(Mid(Chaine2, J, 1))
                                              PrenomCompose = False
                                           Else
                                              Info_A_recuperer2 = Info_A_recuperer2 & Mid(Chaine2, J, 1)
                                           End If
                                End Select
                            Next J
                End Select
                Exit Function
             End If
         Next I
    End With

End Function