Excel VBA Open Word Doc and Save as New Word Doc
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.
Code:
ActiveDocument.SaveAs Filename:=ActiveWorkbook.Path & "/" & Cells(i, 1).Value & " " & Cells(i, 35).Value & " " & Cells(i, 39).Value & ".doc"
And here is the full script.
Code:
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
