使用 Excel 数据库选择行从模板创建文档

Question

此代码的目的是获取 excel 数据库的信息，然后从模板创建一个 word 文档并替换所需的信息。我还放了一些输入框，您可以在其中选择文件保存位置和要创建文档的行。

这就是问题所在。它有效地从我选择的行中获取信息，但是当需要保存时，出于某种原因它保存了 33 个文档，这是我拥有的填充行数。

谁能帮我解决这个问题？它只会创建一个文档，这是我在输入框中输入的文档。而且我还想将其保存为 PDF，但还没有找到如何保存。谢谢，

抱歉有些东西是西班牙语的，但我也试着贴了一个翻译好的。

西班牙语：

' Declaracion de Variables
Dim carpeta As String
Dim renglon As Integer

' Asignacion de valores a variables
carpeta = InputBox("Copie aquí la dirección de la carpeta destino. Por ejemplo: ", "Carpeta destino", "N:\temp\")
renglon = InputBox("Escriba la fila/renglón que desee usar para generar contratos")
    '
    patharch = ThisWorkbook.Path & "\Prueba Local Plantilla.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(renglon, j) 'texto a reemplazar
                objWord.Selection.Move 6, -1
                objWord.Selection.Find.Execute FindText:=textobuscar
            Wend
            '
                
        Next
        ruta = carpeta & "\"
        nombd = "Prueba Local Word " & i & ".docx"
        nombp = "Prueba Local PDF " & i & ".pdf"
        objWord.ActiveDocument.SaveAs ruta & nombd
        pdf = objWord.ActiveDocument.ExportAsFixedFormat(nombp, _
            17, False, 0, 0, , , 0, False, True, 1)
        objWord.Quit (True)
    Next
End Sub

英语：

'Variables
Dim folder As String
Dim row As Integer

' Asignation
folder = InputBox("Paste here the location you want it to save", "Folder", "N:\temp\")
row = InputBox("Type here the row you want the information to be createds to a document")
    '
    patharch = ThisWorkbook.Path & "\Local Test Template.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
            searchtext = Cells(1, j)
            objWord.Selection.Move 6, -1
            objWord.Selection.Find.Execute FindText:=searchtext
            '
            While objWord.Selection.Find.found = True
                objWord.Selection.Text = Cells(renglon, j) 'text to replace
                objWord.Selection.Move 6, -1
                objWord.Selection.Find.Execute FindText:=searchtext
            Wend
            '
                
        Next
        location = folder & "\"
        nombd = "Prueba Local Word " & i & ".docx"
        nombp = "Prueba Local PDF " & i & ".pdf"
        objWord.ActiveDocument.SaveAs location & nombd
        pdf = objWord.ActiveDocument.ExportAsFixedFormat(nombp, _
            17, False, 0, 0, , , 0, False, True, 1)
        objWord.Quit (True)
    Next
End Sub ```

Answer 1

发生这种情况是因为您正在 For i = 2 To Range("A" & Rows.Count).End(xlUp).Row 中创建和保存 Word 文档。在循环开始之前放置以下行：

        Set objWord = CreateObject("Word.Application")
        objWord.Visible = True
        objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0

并在最后 Next 之后放置以下行（参考 Next i （为了便于阅读，添加 i 很有用））：

        location = folder & "\"
        nombd = "Prueba Local Word " & i & ".docx"
        nombp = "Prueba Local PDF " & i & ".pdf"
        objWord.ActiveDocument.SaveAs location & nombd
        pdf = objWord.ActiveDocument.ExportAsFixedFormat(nombp, _
            17, False, 0, 0, , , 0, False, True, 1)
        objWord.Quit (True)

使用 Excel 数据库选择行从模板创建文档

Create Documents from a Templete Using a Excel Database Selecting Row

excel

vba

pdf

ms-word