Macro que exporta datos de excel a word

Parte de los bloques de texto que necesito que cambien automáticamente, están ubicados en el encabezado

Utiliza el siguiente código para cambiar datos en el encabezado:

Sub CorrespondenciaConWord()
  Dim patharch As String, textobuscar As Variant, txtnuevo As Variant
  Dim i As Long, j As Long
  Dim objWord As Object, wdSctn As Object, wdHdFt As Object, rngStory As Object
  '
  patharch = ThisWorkbook.Path & "\plantilla1.dotx"
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    objWord.documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
    For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
      textobuscar = Cells(1, j).Value
      txtnuevo = Cells(i, j).Value
      '
      'Reemplazar datos en el documento
      objWord.Selection.Move 6, -1
      objWord.Selection.Find.Execute FindText:=textobuscar
      While objWord.Selection.Find.found = True
        objWord.Selection.Text = txtnuevo 'texto a reemplazar
        objWord.Selection.Move 6, -1
        objWord.Selection.Find.Execute FindText:=textobuscar
      Wend
      '
      'Reemplazar datos en el encabezado
      For Each wdSctn In objWord.ActiveDocument.Sections
        For Each wdHdFt In wdSctn.Headers
          With wdHdFt
            If .LinkToPrevious = False Then
              With .Range.Find
                .ClearFormatting
                .Text = textobuscar
                With .Replacement
                  .ClearFormatting
                  .Text = txtnuevo
                End With
                .Forward = True
                .Format = False
                .Execute Replace:=1
              End With
            End If
          End With
        Next wdHdFt
      Next wdSctn
    Next j
    '
    objWord.Activate
    objWord.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & Cells(i, "A").Value
    objWord.ActiveDocument.Close
    objWord.Quit
  Next i
End Sub

Hola Dante, gracias por su pronta respuesta. Ajusté el código que usted me envió, pero solo permite el cambio de los datos del encabezado y se detiene con el mensaje: "Se ha producido el error 5458 en tiempo de ejecución: Error definido por la aplicación o el objeto".

El código que use es:

Sub ExportWord()
'Por.DanteAmor
'
Dim patharch As String, textobuscar As Variant, txtnuevo As Variant
Dim i As Long, j As Long
Dim objWord As Object, wdSctn As Object, wdHdFt As Object, rngStory As Object
patharch = ThisWorkbook.Path & "\_Res_NEGACION2020(vr.1)C.dotx"
'
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
textobuscar = Cells(1, j).Value
txtnuevo = Cells(i, j).Value
'
'Reemplazar datos en el documento
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
While objWord.Selection.Find.Found = True
objWord.Selection.Text = txtnuevo 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
'
'Reemplazar datos en el encabezado
For Each wdSctn In objWord.ActiveDocument.Sections
For Each wdHdFt In wdSctn.Headers
With wdHdFt
If .LinkToPrevious = False Then
With .Range.Find
.ClearFormatting
.Text = textobuscar
With .Replacement
.ClearFormatting
.Text = txtnuevo
End With
.Forward = True
.Format = False
.Execute Replace:=1
End With
End If
End With
Next wdHdFt
Next wdSctn
Next j
'
'
MsgBox "Resolución elaborada correctamente"
objWord.Activate
objWord.ActiveDocument.SaveAs "C:\Users\Asus-PC\Desktop\Res_NegacionC\RES_" & Hoja6.Range("A2") & "_" & Hoja6.Range("W3") & ".docx"
End
Next i
End Sub

No encuentro el error

De antemano gracias por la ayuda

Ajusté el código que usted me envió, pero solo permite el cambio de los datos del encabezado y se detiene con el mensaje: "Se ha producido el error 5458 en tiempo de ejecución: Error definido por la aplicación o el objeto".

Primero, cuando pongas código aquí utiliza el icono para insertar código, de esa manera es más fácil de leer.

¿No te dice en cuál línea tiene error?

¿Qué versión de excel y de office tienes?

Ok gracias. No sabía cómo insertar el código.

Cuando depuro el error aparece aquí:

objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0

Le envío el código de forma adecuada

Sub ExportWord()
'Por.DanteAmor
'
Dim patharch As String, textobuscar As Variant, txtnuevo As Variant
Dim i As Long, j As Long
Dim objWord As Object, wdSctn As Object, wdHdFt As Object, rngStory As Object
patharch = ThisWorkbook.Path & "\_Res_NEGACION2020(vr.1)C.dotx"
'
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
textobuscar = Cells(1, j).Value
txtnuevo = Cells(i, j).Value
'
'Reemplazar datos en el documento
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
While objWord.Selection.Find.Found = True
objWord.Selection.Text = txtnuevo 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
'
'Reemplazar datos en el encabezado
For Each wdSctn In objWord.ActiveDocument.Sections
For Each wdHdFt In wdSctn.Headers
With wdHdFt
If .LinkToPrevious = False Then
With .Range.Find
.ClearFormatting
.Text = textobuscar
With .Replacement
.ClearFormatting
.Text = txtnuevo
End With
.Forward = True
.Format = False
.Execute Replace:=1
End With
End If
End With
Next wdHdFt
Next wdSctn
Next j
'
'
MsgBox "Resolución elaborada correctamente"
objWord.Activate
objWord.ActiveDocument.SaveAs "C:\Users\Asus-PC\Desktop\Res_NegacionC\RES_" & Hoja6.Range("A2") & "_" & Hoja6.Range("W3") & ".docx"
End
Next i
End Sub

Gracias nuevamente.

objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0

Pero esa línea está el código original, entonces tenías error antes de solicitar los encabezados?

¿Qué versión de excel y de office tienes?

No ignores mis preguntas, de lo contrario tengo que preguntar otra vez.

Si es del que estaba funcionando anteriormente, pero hasta ahí avanza el Depurador. La versión que uso es 2013.

¿Se detuvo en el primer registro?

¿O actualizó algunos registros?

¿Cuántos registros tienes?

Son en total 25 bloques de texto. Con la primera versión del código (la que usted planteó en un tema anterior) actualizaba todos los bloques, menos los dos que se ubican en el encabezado del archivo Word.

Con esta versión del código, actualiza los tres primeros bloques: los dos del encabezado y el primero que hace parte del cuerpo del texto.

Le envío la primera versión del código 

Sub ExportWord()
'Por: Dante Amor
    '
    patharch = ThisWorkbook.Path & "\_Res_NEGACION2020(vr.1)C.dotx"
    '
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Set objWord = CreateObject("Word.Application")
        objWord.Visible = True
        objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
        '
        For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
            textobuscar = Cells(1, j)
            objWord.Selection.Move 6, -1
            objWord.Selection.Find.Execute FindText:=textobuscar
            '
            While objWord.Selection.Find.Found = True
                objWord.Selection.Text = Cells(i, j) 'texto a reemplazar
                objWord.Selection.Move 6, -1
                objWord.Selection.Find.Execute FindText:=textobuscar 
            Wend
            '
        Next
        '
        MsgBox "Resolución elaborada correctamente"
        objWord.Activate
        objWord.ActiveDocument.SaveAs "C:\Users\Asus-PC\Desktop\Res_NegacionC\RES_" & Hoja6.Range("A2") & "_" & Hoja6.Range("W3") & ".docx"  
        End
    Next
End Sub

¿Pero solamente es un registro en excel o cuántos registros tienes en excel?

Al final tienes estas líneas:

MsgBox "Resolución elaborada correctamente"
objWord.Activate
objWord.ActiveDocument.SaveAs "C:\Users\Asus-PC\Desktop\Res_NegacionC\RES_" & Hoja6.Range("A2") & "_" & Hoja6.Range("W3") & ".docx"

Te faltaron  líneas:

    objWord.Activate
    objWord.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & Cells(i, "A").Value
    objWord.ActiveDocument.Close
    objWord.Quit

Si sr. Es un registro de 25 bloques de texto que cambian según unos datos que ingreso en otra hoja del  archivo Excel.

Estuve verificando línea por línea y el único cambio que se presenta cuando ejecuto la macro es en la línea 

.Text = txtnuevo

Del bloque que le agregamos al código inicial, osea:

'Reemplazar datos en el encabezado
      For Each wdSctn In objWord.ActiveDocument.Sections
        For Each wdHdFt In wdSctn.Headers
          With wdHdFt
            If .LinkToPrevious = False Then
              With .Range.Find
                .ClearFormatting
                .Text = textobuscar
                With .Replacement
                  .ClearFormatting
                  .Text = txtnuevo
                End With
                .Forward = True
                .Format = False
                .Execute Replace:=1
              End With
            End If
          End With
        Next wdHdFt
      Next wdSctn
        Next j

Cuando elimino esa línea, permite adicionar todos los bloques de texto en el archivo Word, menos los del encabezado.

Disculpe tanta molestia, pero estoy varado ahí y necesito ayuda.