Excel VBA 打开 Word 文档并另存为新 Word 文档

Question

我在 Excel 中创建了一个宏来打开 Word docx，交换一些内容，然后我想另存为新的 word docx 并创建 PDF。除了保存新的 Word docx 之外，我一切正常 - 有人可以帮我让它工作吗？

这就是我试图用来保存新单词 docx 的内容 - 如果我删除它，其余部分就可以完美工作。

ActiveDocument.SaveAs Filename:=ActiveWorkbook.Path & "/" & Cells(i, 1).Value & " " & Cells(i, 35).Value & " " & Cells(i, 39).Value & ".doc"

这是完整的脚本。

Sub Secondments()

Dim wd As Word.Application
Dim doc As Word.Document

Set wd = New Word.Application
wd.Visible = True

Dim SetVarFromCell()
Dim Y As Long
Dim X As Long
Y = Worksheets("User Input").Cells(32, "C").Value
X = Y + 1
Dim V As String
Dim P As String
Dim H As String
Dim oRng As Word.Range
Dim para As Word.Paragraph
Dim found As Boolean
Dim A As String
A = ActiveWorkbook.Path & "\"
'MsgBox "The path is " & A, vbInformation

For i = 2 To X
    V = Worksheets("Secondments").Cells(i, 31).Value
    P = Worksheets("Secondments").Cells(i, 33).Value
    H = Worksheets("Secondments").Cells(i, 20).Value

    Set doc = wd.Documents.Open("\\Hbap.adroot.hsbc\au\IT Operations\DATA\Restricted\HeadOffice\HPE\Recruitment Centre\Recruitment Process Australia\Offers\Secondments\Automated Letters\Secondment Template.docx")

    If H = "N" Then
        Set oRng = wd.ActiveDocument.Range
        With oRng.Find
          .Text = "<<HDACopy1>>"
          .Wrap = wdFindStop
          found = .Execute
            Do While found
                Set para = oRng.Next(wdParagraph, 1).Paragraphs(1)
                para.Range.Delete
                Set para = oRng.Next(wdParagraph, -1).Paragraphs(1)
                para.Range.Delete
                oRng.Collapse wdCollapseEnd
                oRng.End = wd.ActiveDocument.Content.End
                found = oRng.Find.Execute
             Loop
        End With
    End If

    If H = "N" Then
        Set oRng = wd.ActiveDocument.Range
        With oRng.Find
          .Text = "<<HDACopy5>>"
          .Wrap = wdFindStop
          found = .Execute
            Do While found
                Set para = oRng.Next(wdParagraph, 1).Paragraphs(1)
                para.Range.Delete
                Set para = oRng.Next(wdParagraph, -1).Paragraphs(1)
                para.Range.Delete
                oRng.Collapse wdCollapseEnd
                oRng.End = wd.ActiveDocument.Content.End
                found = oRng.Find.Execute
             Loop
        End With
    End If

    If V = "N" Then
        Set oRng = wd.ActiveDocument.Range
        With oRng.Find
          .Text = "<<VisaCopy>>"
          .Wrap = wdFindStop
          found = .Execute
            Do While found
                Set para = oRng.Next(wdParagraph, 1).Paragraphs(1)
                para.Range.Delete
                Set para = oRng.Next(wdParagraph, -1).Paragraphs(1)
                para.Range.Delete
                oRng.Collapse wdCollapseEnd
                oRng.End = wd.ActiveDocument.Content.End
                found = oRng.Find.Execute
             Loop
        End With
    End If

    If P = "N" Then
        Set oRng = wd.ActiveDocument.Range
        With oRng.Find
          .Text = "<<PTCopy>>"
          .Wrap = wdFindStop
          found = .Execute
            Do While found
                Set para = oRng.Next(wdParagraph, 1).Paragraphs(1)
                para.Range.Delete
                Set para = oRng.Next(wdParagraph, -1).Paragraphs(1)
                para.Range.Delete
                oRng.Collapse wdCollapseEnd
                oRng.End = wd.ActiveDocument.Content.End
                found = oRng.Find.Execute
             Loop
        End With
    End If

    With wd.Selection.Find
        .Text = "<<CandidateName>>"
        .Replacement.Text = Cells(i, 1).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<Date>>"
        .Replacement.Text = Cells(i, 39).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<Address1>>"
        .Replacement.Text = Cells(i, 3).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<Address2>>"
        .Replacement.Text = Cells(i, 4).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<Address3>>"
        .Replacement.Text = Cells(i, 5).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<EmployeeFirstName>>"
        .Replacement.Text = Cells(i, 6).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<PositionTitle>>"
        .Replacement.Text = Cells(i, 7).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<Salary>>"
        .Replacement.Text = Cells(i, 8).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<StartDate>>"
        .Replacement.Text = Cells(i, 43).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<GCBChange>>"
        .Replacement.Text = Cells(i, 11).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HoursChange>>"
        .Replacement.Text = Cells(i, 14).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<ManagerName>>"
        .Replacement.Text = Cells(i, 17).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<ManagerTitle>>"
        .Replacement.Text = Cells(i, 18).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<CostCentre>>"
        .Replacement.Text = Cells(i, 19).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HDACopy1>>"
        .Replacement.Text = Cells(i, 24).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HDACopy2>>"
        .Replacement.Text = Cells(i, 25).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HDACopy3>>"
        .Replacement.Text = Cells(i, 26).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HDACopy4>>"
        .Replacement.Text = Cells(i, 27).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<HDACopy5>>"
        .Replacement.Text = Cells(i, 28).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<VisaCopy>>"
        .Replacement.Text = Cells(i, 32).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<PTCopy>>"
        .Replacement.Text = Cells(i, 34).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<EndDate>>"
        .Replacement.Text = Cells(i, 47).Value
        .Execute Replace:=wdReplaceAll
    End With

    ActiveDocument.SaveAs Filename:=ActiveWorkbook.Path & "/" & Cells(i, 1).Value & " " & Cells(i, 35).Value & " " & Cells(i, 39).Value & ".doc"

    doc.ExportAsFixedFormat OutputFileName:=ActiveWorkbook.Path & "/" & Cells(i, 1).Value & " " & Cells(i, 35).Value & " " & Cells(i, 39).Value & ".pdf", _
    ExportFormat:=wdExportFormatPDF
      
    Application.DisplayAlerts = False
    doc.Close SaveChanges:=False
    Application.DisplayAlerts = True
        
Next

    wd.Quit

End Sub

我想与 PDF 一起创建一个新的 word docx。

Answer 1

我最终确实解决了这个问题 - 这就是让它发挥作用的原因 -

wd.ActiveDocument.SaveAs2 Filename:=ActiveWorkbook.Path & "/" & Cells(i, 1).Value & " " & Cells(i, 35).Value & " " & Cells(i, 39).Value & ".docx"