Cas particulier: chaîne de caractere

Sub test()
   
' Ajouter la référence à Microsoft Word XX.X Object Library

Dim WordApp As New Word.Application
Dim WordDoc As Word.Document
Dim C As Range
Dim Doc As String, Txt As String, Bal As String
Dim Deb As Long, Fin As Long
Dim freeLine As Long
   
'le document Word est supposé fermé avant le lancement de la macro
With Sheets("Feuil4")
  .Cells.Clear
  'chemin fichier word en entrée choisis par l'user
  fichier = ThisWorkbook.Path & "\test.doc"
  'ouverture du fichier Word
  Set WordDoc = WordApp.Documents.Open(fichier)
  Doc = WordDoc.Range
  'initialisation pointeur
  Deb = 1
  'chercher les textes balisés
  Do
    Deb = InStr(Deb, Doc, "[") + 1
    Fin = InStr(Deb, Doc, "]")
    If Deb = 1 Or Fin = 0 Then Exit Do
    Bal = Mid(Doc, Deb, Fin - Deb)
    Deb = Fin + 1
    Fin = InStr(Deb, Doc, "& Bal & "")
    If Fin > 0 Then
      Txt = Mid(Doc, Deb, Fin - Deb)
      'entete de colonne cad bal
      Set C = .Rows(1).Find(Bal, , , xlWhole)
      If C Is Nothing Then
        If .Cells(1, 1) = "" Then
          Set C = .Cells(1, 1)
        Else
          Set C = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1)
        End If
        'on copie l'entete dans une cellule
        C.Value = Bal
      End If
      freeLine = .Cells(.Rows.Count, C.Column).End(xlUp).Row + 1
      .Cells(freeLine, C.Column) = Txt
    End If
  Loop
  .Columns.AutoFit
End With
   
WordDoc.Close
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
   
End Sub

  'ouverture du fichier Word
  Set WordDoc = WordApp.Documents.Open(fichier)
  Doc = WordDoc.Range
  WordDoc.Close
  WordApp.Quit
  Set WordDoc = Nothing
  Set WordApp = Nothing
  'initialisation pointeur
  ......