Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
    Dim sFolder As String, strFilePattern As String
    Dim strFileName As String, sFileName As String
 Dim i As Long, j As Long, FindWord As String, Ans As String, FoundWord As String, ReplaceAns As String
Call CopyingAFile
        Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
        Set oWordDoc = oWordApp.Documents.Open("E:\Output\Original.docx")
For i = 2 To 40
            FindWord = Sheets("LookUp").Range("B" & i).Value
            If FindWord <> vbNullString Then
            FoundWord = FindWord
       Ans = Sheets("Answers").Range("C" & i).Value
       If Ans <> vbNullString Then
       ReplaceAns = Ans
        For Each rngStory In oWordDoc.StoryRanges
            With rngStory.Find
                .Text = FoundWord
                .Replacement.Text = ReplaceAns
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
        Next
        End If
End If
Next i
        oWordDoc.Close SaveChanges:=True
        MsgBox "File Saved"
    oWordApp.Quit
    MsgBox " Word File Modified"
    Set oWordApp = Nothing: Set oWordDoc = Nothing
End Sub