Autres Transfert de données Excel dans formulaire Word

For x = 4 To dg
indic = Cells(x, 1)
Select Case indic
Case "Editer"
GoTo suite1
Case "x"
If Cells(x, 1) = "Editer" Then GoTo suite1
cellule_D = Cells(x, 9).Value 'cellule date code I/dg
cellule_N = Cells(x, 3).Value 'cellule nom C/dg
cellule_P = Cells(x, 4).Value 'cellule prénom D/dg

fic = cellule_D & cellule_N & "-" & cellule_P 'Nom du nouveau fichier créé
 Set WordApp = CreateObject("word.application")
-----
-
.......


Cells(dg, 1).Value = "Editer" 'remplace le x de la colonne 1 par Editer
Case Else
GoTo suite1
suite1:
End Select

'Texte1 NOM.... Exemple pour celui-ci c'est un (Signet)
'Texte2 PRÉNOM
'Texte3 ADRESSE
'Texte4 Communes
'Texte5 CP
'Texte6 TÉLÉPHONE
' Type Citerne
'Texte15 (Qte) .... Exemple pour celui-ci c'est l'(Option de champ Text)
' Modéle
'CaseACocher1 (Case à cocher) 650L .... Exemple pour celui-ci c'est une (Case à Cocher)
'CaseACocher2 (Case à cocher) 750L
'CaseACocher3 (Case à cocher) 750L
' N° Serie de la siterne
'Texte7 (N°)
' Couleur
'ListeDéroulante1 LaCouleur
' Intstalation General de la citerne
'CaseACocher4 (Case à cocher) OUI
'CaseACocher8 (Case à cocher) Conforme
'CaseACocher12 (Case à cocher) Non Conforme
' Citerne raccordée(s) à la goutière
'CaseACocher5 (Case à cocher) OUI
'CaseACocher9 (Case à cocher) Conforme
'CaseACocher13 (Case à cocher) Non Conforme
'Photo contractuelle prise
'CaseACocher6 (Case à cocher) OUI
'CaseACocher10 (Case à cocher) Conforme
'CaseACocher14 (Case à cocher) Non Conforme
'Installation d'un système de filtration
'CaseACocher7 (Case à cocher) OUI
'CaseACocher11 (Case à cocher) Conforme
'CaseACocher15 (Case à cocher) Non Conforme
' Cachet et signature du plombier : Remarque
'Texte10 (Rem1)
'Texte11 (Rem2)
'Texte12 (Rem3)
'Texte13 (Rem4)
'Texte14 (Rem5)
'Réfection de la descente de gouttière
'CaseACocher16 (Case à cocher)
'Réfection de la gouttière
'CaseACocher17 (Case à cocher)
'Installation d'une gouttière neuve
'CaseACocher18 (Case à cocher)
'Installation d'une descente de gouttière
'CaseACocher19 (Case à cocher)
'Autres travaux
'CaseACocher20 (Case à cocher)
' A
'Texte9 (Lieu)
'LE
'Texte8 (Date)

Sub CompleterWordDepuisExcel()
' Choix nom du dossier d'enregistrement '
    DossierNom = Application.InputBox("Word", "Word", "Nom du dossier WORD ?", Type:=2)
    DossierSauvegard = "C:\" & DossierNom & "\"
' Test si le DossierSauvegard est bien existant
'   * Dans le cas ou il n'existe pas le créer.
    Dim fs As Object
        Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FolderExists(DossierSauvegard) Then
            MsgBox "le repertoire existe donc rien a faire"
        Else
            MsgBox "le repertoire n'existe pas donc on le créer"
            fs.CreateFolder DossierSauvegard
        End If
    Set fs = Nothing
' Test Ouverture Application Word, si pas déjà Ouvert.
On Error Resume Next
    Dim WordApp As Word.Application
        Set WordApp = GetObject(, "Word.Application")
            If Err <> 0 Then
                Err.Clear
                Set WordApp = CreateObject("Word.Application")
            End If
        WordApp.Visible = True 'affiche le document Word
' Documents Word Modéle
    Dim WordDoc As Word.Document
        Set WordDoc = WordApp.Documents("C:\Dossier\BL vierge version 12.docm")
On Error GoTo 0
' Si le Documents Word Modéle est fermé l'Ouvrir.
    If WordDoc Is Nothing Then
        MsgBox "Le document est fermé / Ouvrir le document"
        Set WordDoc = WordApp.Documents.Open("C:\Dossier\BL vierge version 12.docm")
    End If
' Remplir le Document Modéle.
' Comment insérer du texte dans un signet.
' Remplit le signet SignetOrigine avec le texte "LeMot" sans détruire SignetOrigine
' Exemple ci-dessous (Choisir les bonnes Référence excel pour LeMot
    Dim signet(1 To 10) As Word.Bookmark, LeMot(1 To 8) As String, i As Integer
    Dim F As Worksheet
        Set F = Worksheets("ven.-1-oct")
    For i = 4 To F.Cells(65536, 2).End(xlUp).Row - 1
        If F.Cells(i, 1) = "Editer" Then
        ' Word
            Set signet(1) = WordDoc.Bookmarks("Texte1") '[Nom] : nom du signet
            Set signet(2) = WordDoc.Bookmarks("Texte2") '[Prénom] : nom du signet
            Set signet(3) = WordDoc.Bookmarks("Texte3") '[Adresse] : nom du signet
            Set signet(4) = WordDoc.Bookmarks("Texte4") '[Ville] : nom du signet
            Set signet(5) = WordDoc.Bookmarks("Texte5") '[CP] : nom du signet
            Set signet(6) = WordDoc.Bookmarks("Texte6") '[Tel] : nom du signet
            Set signet(7) = WordDoc.Bookmarks("Texte15") '[Qte Citerne] : nom du signet
            Set signet(8) = WordDoc.Bookmarks("CaseACocher1") '[Modèle Citerne 600L] : nom du signet
            Set signet(9) = WordDoc.Bookmarks("CaseACocher2") '[Modèle Citerne 650L] : nom du signet
            Set signet(10) = WordDoc.Bookmarks("CaseACocher3") '[Modèle Citerne 750L] : nom du signet
        ' Excel
            LeMot(1) = F.Range(Cells(i, 3), Cells(i, 3)).Value
            LeMot(2) = F.Range(Cells(i, 4), Cells(i, 4)).Value
            LeMot(3) = F.Range(Cells(i, 5), Cells(i, 5)).Value
            LeMot(4) = F.Range(Cells(i, 6), Cells(i, 6)).Value
            LeMot(5) = F.Range(Cells(i, 7), Cells(i, 7)).Value
            LeMot(6) = F.Range(Cells(i, 8), Cells(i, 8)).Value
            LeMot(7) = F.Range(Cells(i, 2), Cells(i, 2)).Value
            LeMot(8) = F.Range(Cells(i, 14), Cells(i, 14)).Value
        ' Remplir le document Word modele.
            Dim Place As Long, SignetOrigine As String
            For j = LBound(LeMot) To UBound(LeMot)
                ' Quantité Citerne
                If j = 7 Then
                    WordDoc.FormFields("Texte15").Result = LeMot(j)
                ' Modele citerne case a cocher
                ElseIf j = 8 Then
                    Select Case LeMot(j)
                        Case "600"
                            WordDoc.FormFields("CaseACocher1").CheckBox.Value = True
                        Case "650"
                            WordDoc.FormFields("CaseACocher2").CheckBox.Value = True
                        Case "750"
                            WordDoc.FormFields("CaseACocher3").CheckBox.Value = True
                    End Select
                Else
                    ' Depart du signet
                        Place = signet(j).Range.Start
                    ' Nom du signet d'Origine
                        SignetOrigine = signet(j).Name
                    ' Substitue par le Mot (qui remplace le signet)
                        signet(j).Range.Text = LeMot(j)
                    ' Options \ Options Avancées \ Affichér les signets [...]
                    ' Ne pas perdre le Signet d'origine [...] et sa mise en forme entre crochet
                        WordDoc.Bookmarks.Add Name:=SignetOrigine, Range:=WordDoc.Range(Place, Place + Len(LeMot(j)))
                End If
            Next j
        ' Enregistrer le document sous (Exemple : LeMot(1) & "-" & LeMot(2))
            Dim fichier As String
                fichier = "DocumentWordFichier " & LeMot(1) & "-" & LeMot(2) & ".doc"
                WordDoc.SaveAs2 DossierSauvegard & fichier
        ' Suppression des CheckBox et Formtext
                WordDoc.FormFields("Texte15").Result = ""
                WordDoc.FormFields("CaseACocher1").CheckBox.Value = False
                WordDoc.FormFields("CaseACocher2").CheckBox.Value = False
                WordDoc.FormFields("CaseACocher3").CheckBox.Value = False
        ' Les Signets sont recaculer pas besoin de suppression
            [Nota]
        End If
    Next i
    ' Fermer les derniers documents Word
        WordDoc.Close
End Sub

' En récupérant le nom du Formfield, Ont peux l'utiliser pour les signets.
Sub TestOlivier()
Dim myFld As FormField
For Each myFld In ActiveDocument.FormFields
    Debug.Print myFld.Name & " -:::- " & myFld.Result
    myFld.Select
    'myFld.CheckBox.Value = False
Next myFld
End Sub