将文本复制到带有表的文档中

Question

我有一个从Excel生成文档的代码。一方面，我有一个需要填充标记的文档，以生成与Excel中的行一样多的文档。另一方面，我有一个Excel，它在一行中有这个标记，并在Excel的每一行中填写Word文档中要填写的信息。

代码在只有文本和标签的普通文档中工作正常，但是当文档包含填充有文本的表时，它就不工作了...

这些是Excel和文档的一些图像...

带标签的Excel

普通文件

带表格的文件

这是代码：

Sub generate_documents()

    intAnswer = MsgBox("Se dispone a generar los escritos. Antes de continuar confirme que los datos incluidos en la pestaña DATOS son correctos." & Chr(10) & Chr(10) & "¿Está seguro de continuar?", vbYesNo, "ATENCIÓN")

    If (intAnswer <> 6) Then Exit Sub

    Application.Cursor = xlWait
    Application.ScreenUpdating = False

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(ActiveWorkbook.Path)

    strWrittensPath = ActiveWorkbook.Path & "\ESCRITOS (" & Format(Now, "dd-mm-yyyy hhnnss") & ")"
    fso.CreateFolder (strWrittensPath)

    Dim wdApp As Object
    Set wdApp = Nothing
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    intLastRow = Worksheets("DATOS").Range("A" & Rows.Count).End(xlUp).Row

    For Each objFile In objFolder.Files

        If objFile.Type = "Microsoft Word Document" And Left(objFile.Name, 1) <> "~" Then

            For i = 2 To intLastRow

                    strData = " "
                    intColumn = 1

                    wdApp.Documents.Open (objFile.Path)
                    wdApp.ActiveDocument.SaveAs (strWrittensPath & "\" & Worksheets("DATOS").Cells(i, intColumn).Value)

                    Do While strData <> ""

                        intColumn = intColumn + 1

                        strData = Worksheets("DATOS").Cells(1, intColumn).Value
                        strReplace = Worksheets("DATOS").Cells(i, intColumn).Value
                        strReplace = Replace(strReplace, Chr(10), vbCr)

                        If strData <> "" And strReplace <> "" Then

                             If InStr(wdApp.ActiveDocument.Content, strData) = 0 Then

                                intAnswer = MsgBox("No se ha encontrado la etiqueta " & strData & " en el archivo WORD." & Chr(10) & Chr(10) & "¿Desea continuar igualmente?", vbYesNo, "ATENCIÓN")
                                If (intAnswer = 7) Then

                                    wdApp.ActiveDocument.Save
                                    wdApp.ActiveDocument.Close
                                    wdApp.Quit
                                    Set wdApp = Nothing
                                    fso.DeleteFolder (strWrittensPath)
                                    Application.Cursor = xlDefault
                                    Exit Sub

                                End If

                            Else

                                    wdApp.ActiveDocument.Content.Find.Execute _
                                    FindText:=strData, ReplaceWith:=strReplace, Replace:=2, Forward:=True, MatchWholeWord:=True

                                End If

                            End If

                    Loop

                    wdApp.ActiveDocument.Save
                    wdApp.ActiveDocument.Close

            Next i

        End If

    Next objFile

    wdApp.Quit
    Set wdApp = Nothing
    Application.CutCopyMode = False
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True

    intAnswer = MsgBox("Los documentos se han generado con exito." & Chr(10) & Chr(10) & "¿Desea abrir la carpeta que contiene los documentos?", vbYesNo, "Información")
    If (intAnswer = 6) Then Shell "explorer.exe" & " " & strWrittensPath, vbNormalFocus

End Sub

Answer 1

它工作得很好，问题是我试图写一个扩展名为. doc的文档，而不是. docx，现在有了. docx，就没有问题了。