Display glitch. Extra space after apostrophe when creating word documents VBA - vba

Question

I have this VBA code that takes two documents (one original document and one revision document with blue text to be added) and creates a third document with the revisions.It mostly works, but when the third copy is created, there is extra space after apostrophes. It isn't actually an extra space though. Upon selecting the "Hidden Formatting" button in Word, it shows that there isn't actually a space at all. The character is just being displayed on the monitor incorrectly. I have tried a few things such as changing the font during the file creation and using the REPLACE function to no avail. This is not an isolated incident, I found this documentation on the problem, unfortunately it does not pertain to VBA. Looking for some ideas on how to fix the problem.
Sub WordReplaceSentence()
MsgBox "Welcome to the word document automatic modifier", vbInformation + vbOKOnly
MsgBox "Please open the revision file", vbInformation + vbOKOnly
Dim strfilename1 As String
Dim fd1 As Office.FileDialog
''''''Browsing/Opening the change request'''''''
Set fd1 = Application.FileDialog(msoFileDialogFilePicker)
With fd1
.AllowMultiSelect = False
.Title = "Open the modified word document."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename1 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
MsgBox "Open the orginal document", vbInformation + vbOKOnly
Dim strfilename2 As String
Dim fd2 As Office.FileDialog
Set fd2 = Application.FileDialog(msoFileDialogFilePicker)
With fd2
.AllowMultiSelect = False
.Title = "Please select the original file."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename2 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
MsgBox "Please enter the file name with which you want to store the new updated file", vbInformation + vbOKOnly
''''''''''''''''''Asking user to input name to the new revised document'''''''''''''''''''''''''''''''''''''
Dim strfilename3 As String
Dim fd3 As Office.FileDialog
Set fd3 = Application.FileDialog(msoFileDialogSaveAs)
With fd3
.AllowMultiSelect = False
.Title = "Please select the name to be given to the new file."
If .Show = True Then
strfilename3 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
FileCopy strfilename2, strfilename3
Set objWordChange = CreateObject("Word.Application")
Set objWordorig = CreateObject("Word.Application")
objWordChange.Visible = False
objWordorig.Visible = False
Set objDocChange = objWordChange.Documents.Open(strfilename1)
Set objSelectionChange = objWordChange.Selection
Set objDocOrig = objWordorig.Documents.Open(strfilename3)
Set objSelectionOrig = objWordorig.Selection
Dim rSearch As Range
Dim dict As Scripting.Dictionary
Dim i As Long
'We'll store the sentences here
Set dict = New Scripting.Dictionary
Set rSearch = objDocChange.Range
With rSearch
.Find.Forward = True
.Find.Format = True
.Find.Font.Color = wdColorBlue
.Find.Execute
Do While .Find.Found
'key = revised sentence, item = original sentence
'if the revised sentence already exists in the dictionary, replace the found word in the entry
If dict.Exists(.Sentences(1).Text) Then
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), Space(2), Space(1))
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " ,", ",")
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " .", ".")
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " '", "'")
For Each Key In dict
Debug.Print "KEY: " & Key
Debug.Print "Item: " & Item
Next
Else
'if the revised sentence isn't in the dict, then this is the first found word, so add it and replace the word
dict.Add .Sentences(1).Text, Replace$(Replace$(.Sentences(1).Text, .Text, vbNullString), Space(2), Space(1))
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " ,", ",")
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " .", ".")
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), " '", "'")
End If
.Find.Execute
Loop
End With
'Loop through all the dictionary entries and find the origial (item) and replace With
'the revised (key)
For i = 1 To dict.Count
Set rSearch = objDocOrig.Range
With rSearch.Find
.MatchWholeWord = False
.MatchCase = False
.MatchPhrase = True
.IgnoreSpace = True
.IgnorePunct = True
.Wrap = wdFindContinue
.Text = dict.Items(i - 1)
.Replacement.Text = dict.Keys(i - 1)
.Execute Replace:=wdReplaceOne
End With
With objDocOrig.Range
.Font.Name = "Calibri"
End With
Next i
objDocChange.Close
objDocOrig.Save
objDocOrig.Close
objWordChange.Quit
objWordorig.Quit
End Sub
If you need / want to test my code, you will have to create two word documents. Each document will need a common sentence containing an apostrophe (obviously). The second document would require a few blue words in addition to the original sentence in RGB 0,0,225.

Answer 1

Found an answer to my own question. I had to disable the "Asian Text Font" in the Font Pane. This can be done by going into the Microsoft Language Register and disabling various languages. Source