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

[Aussiebear]

Welcome to VBAX Grant82. I notice you have two loops of "If H = "N"". A typo perhaps?

[Grant82]

Hi Aussiebear, thanks for taking a look! That part is OK though - the first loop is removing spacing around <<HDACopy1>> and the second one is removing space around <<HDACopy5>>. All the code except for the line I use to try to save as a new word doc does work however - it's just that one bit I need some help with.

If I comment this bit out the rest runs and completes successfully outputting a PDF. But, I want a new word doc saved as well as the PDF - so how do I get this bit working?


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

[Aussiebear]

Okay so the system is playing games with me. What I had meant to say is the Slash should be backwards not forwards

[Grant82]

I finally got it sussed - here's what worked-


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

[Aussiebear]

Glad you arrived at a solution. I'm sure the Word guru's when they arrive, might put their two cents in as well so keep an eye on this thread of yours. Do you wan tto mark the thread as solved? If so go to Thread tools, scroll down to Mark this thread as Solved please?

[snb]

You should use Docvariables instead of find/replace.

To open a Word documnet:


With getobject("G:\OF\sample.docx")

End With

To read values in an Excel document use an array; so you can reduce the interaction with the sheet to once.

[Dave]

Excel VBA Open Word Doc and Save as New Word Doc | MrExcel Message Board (https://www.mrexcel.com/board/threads/excel-vba-open-word-doc-and-save-as-new-word-doc.1257056/)
Maybe review both sites guidelines re. cross posting
Dave

[Aussiebear]

Well, thats disappointing.....