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\Secondme 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.....

[Aussiebear]

Maybe this version might also assist?


Sub Secondments()
' Declare variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wsInput As Worksheet
Dim wsSecondments As Worksheet
Dim lastRow As Long
Dim i As Long
Dim targetPath As String
Dim fileName As String
Dim found As Boolean
Dim oRng As Word.Range ' Declare the Word Range object
Dim para As Word.Paragraph 'Declare the Word Paragraph object
' Set object variables
Set wdApp = New Word.Application
Set wsInput = ThisWorkbook.Worksheets("User Input")
Set wsSecondments = ThisWorkbook.Worksheets("Secondments")
' Set Word application to be visible (optional, for debugging)
wdApp.Visible = True
' Get the last row from "Secondments" sheet
lastRow = wsSecondments.Cells(wsSecondments.Rows.Count, "A").End(xlUp).Row
' Define the target path. Use a constant for the template path.
Const TEMPLATE_PATH As String = "\\Hbap.adroot.hsbc\au\IT Operations\DATA\Restricted\HeadOffice\HPE\Recruitment Centre\Recruitment Process Australia\ _
Offers\Secondments\Automated Letters\Secondme Template.docx"
targetPath = ThisWorkbook.Path & "\" ' Corrected path concatenation
' Loop through the rows in "Secondments" sheet
For i = 2 To lastRow
' Open the Word document (use the constant)
Set wdDoc = wdApp.Documents.Open(TEMPLATE_PATH)
' Check if the document was opened successfully
If Not wdDoc Is Nothing Then
' Optimize: Get values from the worksheet into variables. This is much faster.
Dim H As String, V As String, P As String
H = wsSecondments.Cells(i, 20).Value
V = wsSecondments.Cells(i, 31).Value
P = wsSecondments.Cells(i, 33).Value
' Delete paragraphs based on conditions (H, V, P)
' Combine the logic for deleting paragraphs for efficiency
Set oRng = wdDoc.Content 'Set the range to the entire document.
oRng.Find.Wrap = wdFindStop 'Set the Wrap property of the Find object
If H = "N" Then
DeleteParagraphs oRng, "<<HDACopy1>>"
DeleteParagraphs oRng, "<<HDACopy5>>"
End If
If V = "N" Then
DeleteParagraphs oRng, "<<VisaCopy>>"
End If
If P = "N" Then
DeleteParagraphs oRng, "<<PTCopy>>"
End If
' Perform find and replace operations
With oRng.Find 'Use the same range object
.Execute FindText:="<<CandidateName>>", ReplaceWith:=wsSecondments.Cells(i, 1).Value, Replace:=wdReplaceAll
.Execute FindText:="<<Date>>", ReplaceWith:=wsSecondments.Cells(i, 39).Value, Replace:=wdReplaceAll
.Execute FindText:="<<Address1>>", ReplaceWith:=wsSecondments.Cells(i, 3).Value, Replace:=wdReplaceAll
.Execute FindText:="<<Address2>>", ReplaceWith:=wsSecondments.Cells(i, 4).Value, Replace:=wdReplaceAll
.Execute FindText:="<<Address3>>", ReplaceWith:=wsSecondments.Cells(i, 5).Value, Replace:=wdReplaceAll
.Execute FindText:="<<EmployeeFirstName>>", ReplaceWith:=wsSecondments.Cells(i, 6).Value, Replace:=wdReplaceAll
.Execute FindText:="<<PositionTitle>>", ReplaceWith:=wsSecondments.Cells(i, 7).Value, Replace:=wdReplaceAll
.Execute FindText:="<<Salary>>", ReplaceWith:=wsSecondments.Cells(i, 8).Value, Replace:=wdReplaceAll
.Execute FindText:="<<StartDate>>", ReplaceWith:=wsSecondments.Cells(i, 43).Value, Replace:=wdReplaceAll
.Execute FindText:="<<GCBChange>>", ReplaceWith:=wsSecondments.Cells(i, 11).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HoursChange>>", ReplaceWith:=wsSecondments.Cells(i, 14).Value, Replace:=wdReplaceAll
.Execute FindText:="<<ManagerName>>", ReplaceWith:=wsSecondments.Cells(i, 17).Value, Replace:=wdReplaceAll
.Execute FindText:="<<ManagerTitle>>", ReplaceWith:=wsSecondments.Cells(i, 18).Value, Replace:=wdReplaceAll
.Execute FindText:="<<CostCentre>>", ReplaceWith:=wsSecondments.Cells(i, 19).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HDACopy1>>", ReplaceWith:=wsSecondments.Cells(i, 24).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HDACopy2>>", ReplaceWith:=wsSecondments.Cells(i, 25).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HDACopy3>>", ReplaceWith:=wsSecondments.Cells(i, 26).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HDACopy4>>", ReplaceWith:=wsSecondments.Cells(i, 27).Value, Replace:=wdReplaceAll
.Execute FindText:="<<HDACopy5>>", ReplaceWith:=wsSecondments.Cells(i, 28).Value, Replace:=wdReplaceAll
.Execute FindText:="<<VisaCopy>>", ReplaceWith:=wsSecondments.Cells(i, 32).Value, Replace:=wdReplaceAll
.Execute FindText:="<<PTCopy>>", ReplaceWith:=wsSecondments.Cells(i, 34).Value, Replace:=wdReplaceAll
.Execute FindText:="<<EndDate>>", ReplaceWith:=wsSecondments.Cells(i, 47).Value, Replace:=wdReplaceAll
End With
' Construct the filename
fileName = wsSecondments.Cells(i, 1).Value & " " & wsSecondments.Cells(i, 35).Value & " " & wsSecondments.Cells(i, 39).Value
' Save the Word document
wdDoc.SaveAs2 Filename:=targetPath & fileName & ".docx"
' Export to PDF
wdDoc.ExportAsFixedFormat OutputFileName:=targetPath & fileName & ".pdf", ExportFormat:=wdExportFormatPDF
' Close the Word document
wdDoc.Close SaveChanges:=False
Else
MsgBox "Failed to open document: " & TEMPLATE_PATH, vbCritical
End If
Next i
' Quit Word
wdApp.Quit
Set wdApp = Nothing ' Release the object variable
End Sub


' Subroutine to delete paragraphs containing specific text

Sub DeleteParagraphs(ByRef oRng As Word.Range, ByVal searchText As String)
Dim found As Boolean
Dim para As Word.Paragraph
With oRng.Find
.Text = searchText
.Wrap = wdFindStop
found = .Execute
Do While found
Set para = oRng.Paragraphs(1) 'Gets the paragraph where the search text was found
para.Range.Delete
oRng.Collapse wdCollapseEnd
found = .Execute
Loop
End With
End Sub