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
Maybe review both sites guidelines re. cross posting
Dave

[Aussiebear]

Well, thats disappointing.....