Sub CreateWordDocTest()

Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim myStoryRange As Word.Range
Dim InsName, InsNumber, CurrentYear, Industry, AnalysisToolPath, AnalysisToolName, FileNameFragment2, TodaysDate, TemplatePath As String

If RADType = "Full" Then
    TemplatePath = Sheets("Metadata").Range("D8").Value
    NotificationWhenDone = "Full RAD done"
    TodaysDate = Now()                                          'Variable called TodaysDate would now contain the current system date and time
Else
    TemplatePath = Sheets("Metadata").Range("D6").Value
    NotificationWhenDone = "Summary RAD done"
    TodaysDate = Now()
End If

Set wApp = CreateObject("Word.Application")
wApp.Visible = True                                             'Creates an instance of Word an makes it visible
Set wDoc = wApp.Documents.Open(TemplatePath, False)             'Opens the chosen full or summary RAD template

With wDoc                                               'Use the With statement to not repeat wDoc many times

'Start at the beginning of the Word document

    .Application.Selection.HomeKey Unit:=wdStory        'Moves the selection to the beginning of the current story

InsName = Sheets("Parameters").Range("D4").Value
InsNumber = Sheets("Parameters").Range("D5").Value
CurrentYear = Sheets("Parameters").Range("D6").Value
Industry = Sheets("Parameters").Range("D7").Value
AnalysisToolPath = Sheets("Metadata").Range("D2").Value
FileNameFragment2 = InsNumber & " - " & InsName & " " & CurrentYear & ".xlsm"
AnalysisToolName = AnalysisToolPath & FileNameFragment2

'Write insurer name

   For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange.Find
    .Text = "<<InsurerName>>"                   'Find the exact text in the Word document
    .Replacement.Text = InsName                 'Replace this text with the insurername as defined
    .Wrap = wdFindContinue                      'The find operation continues when the beginning or end of the search range is reached
    .Execute Replace:=wdReplaceAll              'Finds all occurences and executes the replacement
    End With

    Next myStoryRange
    .Application.Selection.EndOf                'Selects until the end of the document

'Write insurer class
    For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange.Find
        .Text = "<<InsurerClass>>"
        .Replacement.Text = Industry
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With

    Next myStoryRange
    .Application.Selection.EndOf

'Write financial year
    For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange.Find
        .Text = "<<CurrentYear>>"
        .Replacement.Text = CurrentYear
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With

    Next myStoryRange
    .Application.Selection.EndOf

'Write significant classes
    For Each myStoryRange In ActiveDocument.StoryRanges
        With myStoryRange.Find
            .Text = "<<SignificantClasses>>"
            .Replacement.Text = SignificantclassesTxt
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next myStoryRange
    .Application.Selection.EndOf

'Write insurer number
    .Application.Selection.Find.Text = "<<InsurerNumber>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheets("Parameters").Range("D5").Value
    .Application.Selection.EndOf

'Write analyst name
    .Application.Selection.Find.Text = "<<AnalystName>>"
    .Application.Selection.Find.Execute
    .Application.Selection = UserFullName
    .Application.Selection.EndOf

'Write RiBS Wording
    .Application.Selection.Find.Text = "<<RiBSWording>>"
    .Application.Selection.Find.Execute
    .Application.Selection = SignificantclassesRiBSTxt
    .Application.Selection.EndOf

End With

End Sub