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
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