Excel VBA Open Word Doc and Save as New Word Doc

[Grant82]

I've created a macro in Excel to open a Word docx, swap out some content, and then I want to save as a new word docx as well as create a PDF. I have everything working except for the saving a new Word docx - can somebody help me getting it to work please?


This is what I'm trying to use for saving a new word docx - and if I remove this, the rest works perfectly.

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

And here is the full script.

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<file://Hbap.adroot.hsbc/au/IT%20Operations/DATA/Restricted/HeadOffice/HPE/Recruitment%20Centre/Recruitment%20Process%20Australia/Offers/Secondments/Automated%20Letters/Secondment%20Template.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