Mettre un x dans une case à cocher d'un fichier Word depuis Excel

    Dim traitementTexte As Word.Application
    Set traitementTexte = New Word.Application
Dim u As String
    traitementTexte.Visible = True
 
   
    Dim leDoc As Document
    Set leDoc = traitementTexte.Documents.Open(ActiveWorkbook.Path & "/TON FICHIER WORD.doc")
 
    
    leDoc.Content.Find.Execute FindText:="<BALISE1>", ReplaceWith:=Feuil8.Range("B1").Value, Replace:=WdReplaceAll
    leDoc.Content.Find.Execute FindText:="<BALISE2>", ReplaceWith:=Feuil8.Range("B3").Value, Replace:=WdReplaceAll
    leDoc.Content.Find.Execute FindText:="<BALISE3>", ReplaceWith:=Date, Replace:=WdReplaceAll
    Feuil8.Range("B5").Value = UCase(Feuil8.Range("B5").Value)
    leDoc.Content.Find.Execute FindText:="<BALISE4>", ReplaceWith:=Feuil8.Range("B5").Value, Replace:=WdReplaceAll
     
     u = Feuil8.Range("B6").Text
     u = UCase(u)
 
    leDoc.Content.Find.Execute FindText:="<BALISE5>", ReplaceWith:=u, Replace:=WdReplaceAll
    leDoc.Content.Find.Execute FindText:="<BALISE6>", ReplaceWith:=Feuil8.Range("B7").Value, Replace:=WdReplaceAll
    Feuil8.Range("B8").Value = UCase(Feuil8.Range("B8").Value)
    leDoc.Content.Find.Execute FindText:="<BALISE7>", ReplaceWith:=Feuil8.Range("B8").Value, Replace:=WdReplaceAll
    leDoc.Content.Find.Execute FindText:="<BALISE8>", ReplaceWith:=Feuil8.Range("B4").Value, Replace:=WdReplaceAll
    Feuil8.Range("B9").Value = UCase(Feuil8.Range("B9").Value)
    leDoc.Content.Find.Execute FindText:="<BALISE10>", ReplaceWith:=Feuil8.Range("B9").Value, Replace:=WdReplaceAll
    Feuil8.Range("B12").Value = UCase(Feuil8.Range("B12").Value)
    leDoc.Content.Find.Execute FindText:="<BALISE11>", ReplaceWith:=Feuil8.Range("B12").Value, Replace:=WdReplaceAll
    leDoc.Content.Find.Execute FindText:="<BALISE12>", ReplaceWith:=Feuil8.Range("B12").Value, Replace:=WdReplaceAll
    
    
    leDoc.Content.Find.Execute FindText:="<BALISE13>", ReplaceWith:=Feuil8.Range("B1").Value, Replace:=WdReplaceAll

If Feuil8.Range("B22").Value = "X" Then
leDoc.Content.Find.Execute FindText:="<1>", ReplaceWith:="X", Replace:=WdReplaceAll
Else
leDoc.Content.Find.Execute FindText:="<1>", ReplaceWith:="", Replace:=WdReplaceAll
End If
   If Feuil8.Range("B23").Value = "X" Then
   leDoc.Content.Find.Execute FindText:="<2>", ReplaceWith:="X", Replace:=WdReplaceAll
   Else
   leDoc.Content.Find.Execute FindText:="<2>", ReplaceWith:="", Replace:=WdReplaceAll
   End If
        If Feuil8.Range("B24").Value = "X" Then
        leDoc.Content.Find.Execute FindText:="<3>", ReplaceWith:="X", Replace:=WdReplaceAll
        Else
        leDoc.Content.Find.Execute FindText:="<3>", ReplaceWith:="", Replace:=WdReplaceAll
        End If
   End Sub

Feuil8.Cells.Replace "Mr Didier Lapince", "Mr D.LAPINCE"

leDoc.Content.Find.Execute FindText:="<BALISE1>", ReplaceWith:=Replace(Feuil8.Range("B1"), "Mr Didier Lapince", "Mr D.LAPINCE"), Replace:=WdReplaceAll

Dim x$, s, y$
x = Application.Trim(Feuil8.[B1]) 'SUPPRESPACE
s = Split(x)
y = UCase(Left(s(1), 1) & "." & Mid(x, Len(s(0) & s(1)) + 3))
x = s(0) & " " & y
MsgBox x 'pour tester
MsgBox y 'pour tester (c'est le texte à mettre en gras)

With leDoc.Bookmarks("Balise1")
leDoc.Range(.Start + Len(x) - Len(y), .End).Font.Bold = True
End With

With leDoc.Content.Find
  .Text = y
  .Forward = True
  .Execute
  .Parent.Bold = True
End With

Dim x$, y$, s
'---
x = Application.Trim(Feuil8.[B1]) 'SUPPRESPACE
y = ""
s = Split(x)
If UBound(s) > 0 Then _
  y = UCase(Left(s(1), 1) & "." & Mid(x, Len(s(0) & s(1)) + 3))
If x <> "" Then x = RTrim(s(0) & " " & y)
With leDoc.Content.Find
  .Execute "<BALISE1>", ReplaceWith:=x, Replace:=wdReplaceAll
  If .Found And y <> "" Then
    .Text = y
    .Forward = True
    .Execute
    .Parent.Bold = True
  End If
End With
'---à répéter éventuellement sur d'autres cellules---

Dim nom$, x$, y$, s, i
'---
nom = "Signet1" 'nom du signet à atteindre
If leDoc.Bookmarks.Exists(nom) Then
  x = Application.Trim(Feuil8.[B1]) 'SUPPRESPACE
  y = ""
  s = Split(x)
  If UBound(s) > 0 Then _
    y = UCase(Left(s(1), 1) & "." & Mid(x, Len(s(0) & s(1)) + 3))
  If x <> "" Then x = RTrim(s(0) & " " & y)
  i = leDoc.Bookmarks(nom).Start
  leDoc.Bookmarks(nom).Range = x
  leDoc.Range(i + Len(x) - Len(y), i + Len(x)).Font.Bold = True
  leDoc.Bookmarks.Add nom, leDoc.Range(i, i + Len(x)) 'redéfinition
Else
  MsgBox "Le signet '" & nom & "' n'existe pas..."
End If
'---à répéter éventuellement sur d'autres signets et cellules---