Question

我有一个从Excel生成文档的代码。一方面，我有一个文档，其中包含要填充的标记，以生成与Excel中的行一样多的文档。另一方面，我有一个带有此标记的Excel，并且在Excel的每个后续行中填写了要填写的Word文档中的信息。

代码适用于只包含文本和标记的普通文档，但是当文档包含填充文本的表格时，它无效...

这些是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，没有问题。

使用表格将文本复制到文档中

1 个答案: