Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Nov 2021 

 
Sub ReplaceInStoryRanges()
Const sPath As String = "C:\Path\docname.docx" ' the path of the document
Dim WordDoc As Object
Dim wdApp As Object
Dim oStory As Object
Dim oShp As Object
Dim bFormat As Boolean

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set WordDoc = wdApp.Documents.Open(sPath) 'works in Word even if the document is already open

    bFormat = wdApp.Options.AutoFormatAsYouTypeReplaceQuotes
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = False
    For Each oStory In WordDoc.StoryRanges
        Select Case oStory.StoryType
            Case 1 To 11
                Do
                    ReplaceQuotes wdApp, WordDoc, oStory
                    DoEvents
                    On Error GoTo 0
                    Select Case oStory.StoryType
                        Case 6, 7, 8, 9, 10, 11
                            If oStory.ShapeRange.Count > 0 Then
                                For Each oShp In oStory.ShapeRange
                                    If oShp.TextFrame.HasText Then
                                        ReplaceQuotes wdApp, WordDoc, oStory
                                    End If
                                    DoEvents
                                Next oShp
                            End If
                        Case Else
                    End Select
                    On Error GoTo 0
                    Set oStory = oStory.NextStoryRange
                Loop Until oStory Is Nothing
            Case Else
        End Select
        DoEvents
    Next oStory
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = bFormat
End Sub

Sub ReplaceQuotes(wdApp As Object, oDoc As Object, oRng As Object)
Dim oFind As Object
Dim vFindText As Variant
Dim vReplText As Variant
Dim bQuotes As String
Dim i As Long
    vFindText = Array(Chr(132), Chr(147), Chr(148), ChrW(171) & ChrW(160), ChrW(160) & ChrW(187), Chr(145), Chr(146))
    vReplText = Array(Chr(34), Chr(34), Chr(34), Chr(34), Chr(34), Chr(39), Chr(39))
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = False
    For i = LBound(vFindText) To UBound(vFindText)
        Set oFind = oRng.Duplicate
        With oFind.Find
            Do While .Execute(vFindText(i))
                oFind.Text = vReplText(i)
                oFind.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Set oFind = Nothing
    Exit Sub
End Sub

'---------------------------------------------------------------------------------------
' Procedure         : replace_quotes_with_smart_quotes
' Author            : RMittelman@gmail.com
'
' Purpose           : Replaces plain apostrophes & quotes with Word smart quotes
'
' History           :   11/14/2021  Initial version
'                       11/20/2021  Replaced Regex code with Word Find code
'
' Returns           : Boolean indicating success or failure.
'
' Notes             :
'
'---------------------------------------------------------------------------------------
'
Private Function replace_quotes_with_smart_quotes() As Boolean

    Dim myStoryRange    As Object
    Dim arFind          As Variant
    Dim arReplace       As Variant
    Dim i               As Integer
    
    replace_quotes_with_smart_quotes = False
    On Error GoTo error_handler
    
    arFind = Array(" '", "'", " """, """")
    arReplace = Array(Chr$(145), Chr$(146), Chr$(147), Chr$(148))
    
    For Each myStoryRange In WordDoc.StoryRanges
        With myStoryRange.Find
            
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .ClearFormatting
            
            For i = 0 To UBound(arFind)
                .Text = arFind(i)
                .Replacement.Text = arReplace(i)
                .Replacement.ClearFormatting
                .Replacement.Highlight = False
                .Execute Replace:=wdReplaceAll
            Next
            
        End With
    Next myStoryRange

    replace_quotes_with_smart_quotes = True
    
exit_handler:
    
    On Error Resume Next
    Set myStoryRange = Nothing
    Exit Function
    
error_handler:
    
    m_LastError = Err.Description
    If MsgBoxEx(Err.Description, vbRetryCancel + vbExclamation + vbDefaultButton2, "Error " & Err.Number, , , vbRed, , "&Debug", "&Exit") = vbRetry Then
        Stop
        Resume
    End If
    
    replace_quotes_with_smart_quotes = False
    Resume exit_handler

End Function