Open Word Template, change, save, close and open again

[Sethomas5]

Hello and thank you in advance!
Running Excel and Word 2013 on Windows 7.

I am trying to get a macro to run on all of the worksheets except 2 in my active workbook. After each worksheet does its thing to fill the word template, I want it to save it as the name of said worksheet, close the template and move on to the next worksheet which should open the template again to make the changes and save...until the end.

This is the macro I'm working on.

Sub RunThisOne()
Dim objWord As Object
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "equivalents" Or ws.Name <> "Core Category" Then

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    objWord.Documents.Open "C:\Users\thomassa\Desktop\thistemplate.dotm" ' change as required

    With objWord.ActiveDocument
    
 .Bookmarks("EKU_Major").Range.Text = ws.Name

    If ws.Range("I1").Value = "Heritage" Then GoTo Line1 Else GoTo Line2
    
Line1:
    .Bookmarks("Heritage_Class1").Range.Text = ws.Range("I6").Value
    .Bookmarks("Heritage_Class2").Range.Text = ws.Range("I7").Value
    .Bookmarks("Heritage_Class3").Range.Text = ws.Range("I8").Value
    
Line2:
    If ws.Range("I1").Value = "Humanities" Then GoTo Line3 Else GoTo Line4
    
Line3:
    .Bookmarks("Humanities_Class1").Range.Text = ws.Range("I6").Value & "/" & ws.Range("G6").Value
   
Line4:
    MsgBox "Doesn't exist, sorry"
    End With
    Set objWord = Nothing
Worksheets(ActiveSheet.Index + 1).Select
End If

Next ws



End Sub

 

[Norie]

You don't say what you need help with or what problems you have but give this, untested, code a try.

Option Explicit

Sub RunThisOne()
Dim objWord As Object
Dim objDoc As Object
Dim ws As Worksheet

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "equivalents" Or ws.Name <> "Core Category" Then

            ' create new document based on template
            Set objDoc = objWord.Documents.Add("C:\Users\thomassa\Desktop\thistemplate.dotm")      ' change as required

            With objDoc

                .Bookmarks("EKU_Major").Range.Text = ws.Name

                Select Case ws.Range("I1").Value
                    Case "Heritage"
                        .Bookmarks("Heritage_Class1").Range.Text = ws.Range("I6").Value
                        .Bookmarks("Heritage_Class2").Range.Text = ws.Range("I7").Value
                        .Bookmarks("Heritage_Class3").Range.Text = ws.Range("I8").Value
                    Case "Humanities"
                        .Bookmarks("Humanities_Class1").Range.Text = ws.Range("I6").Value & "/" & ws.Range("G6").Value
                    Case Else
                        MsgBox "Doesn't exist, sorry"
                End Select

                .SaveAs ThisWorkbook.Path & "\" & ws.Name & ".docx"

                .Close

            End With

            Set objDoc = Nothing
        End If

    Next ws

    objWord.Quit

    Set objWord = Nothing

End Sub

 

[Sethomas5]

You don't say what you need help with or what problems you have but give this, untested, code a try.

Option Explicit

Sub RunThisOne()
Dim objWord As Object
Dim objDoc As Object
Dim ws As Worksheet

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "equivalents" Or ws.Name <> "Core Category" Then

            ' create new document based on template
            Set objDoc = objWord.Documents.Add("C:\Users\thomassa\Desktop\thistemplate.dotm")      ' change as required

            With objDoc

                .Bookmarks("EKU_Major").Range.Text = ws.Name

                Select Case ws.Range("I1").Value
                    Case "Heritage"
                        .Bookmarks("Heritage_Class1").Range.Text = ws.Range("I6").Value
                        .Bookmarks("Heritage_Class2").Range.Text = ws.Range("I7").Value
                        .Bookmarks("Heritage_Class3").Range.Text = ws.Range("I8").Value
                    Case "Humanities"
                        .Bookmarks("Humanities_Class1").Range.Text = ws.Range("I6").Value & "/" & ws.Range("G6").Value
                    Case Else
                        MsgBox "Doesn't exist, sorry"
                End Select

                .SaveAs ThisWorkbook.Path & "\" & ws.Name & ".docx"

                .Close

            End With

            Set objDoc = Nothing
        End If

    Next ws

    objWord.Quit

    Set objWord = Nothing

End Sub

Worked perfectly!!! Thank you!
Sorry for taking so long to reply, I was working on a few other pieces of my project.