Delete all misspelled words in Microsoft Word document

I have numerous word documents with misspelt words that I'm hoping to batch delete. I've tried both of the solutions mentioned below, but they all seem to fail for me.

https://answers.microsoft.com/en-us/msoffice/forum/all/how-to-remove-all-misspelled-words-in-ms-word-at/608dbb5d-e719-4b5f-b44e-1b0542b66bd7

Sub DeleteSpellingErrors()
Dim rng As word.Range, i As Integer
If Selection.Range.Start = Selection.Range.End Then
    Set rng = ActiveDocument.Content
Else
    Set rng = Selection.Range
End If
If rng.SpellingErrors.Count > 0 Then
    For i = rng.SpellingErrors.Count To 1 Step -1
        rng.SpellingErrors(i).Delete
    Next
End If
End Sub

https://answers.microsoft.com/en-us/msoffice/forum/all/remove-all-misspelled-words-in-my-word-document/b686c318-c1fc-4d90-9e56-e922bb556abd

Using these macro codes causes my microsoft word to freeze (I'm using a 10th gen intel i7) indefinitely. Despite having waited for hours, there still hasn't been any progress. It seems to me like these codes only work for shorter documents, but because my word docs have more than 200 pages, it seems to freeze. Does anyone have any other code suggestions? Better yet, does anyone have any suggestions that allow me to batch delete misspelt words across multiple word docs? Currently, I am deleting misspelt words one document at a time. Thanks for any help!

Solution

Try if this code snippet is a bit faster:

    Sub DeleteSpellingErrors()
    Dim cnt As Long
    Dim cur As Range
    Dim doc As Document
    Set doc = ActiveDocument
    cnt = doc.Range.SpellingErrors.Count
    Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToFirst)
    For i = 1 To cnt
        cur.Select
        cur.Delete
        Debug.Print cnt & " " & i
        Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToNext)
        DoEvents
    Next
End Sub

Most probably you will have to re-run the procedure two or three times as I see that SpellingErrors.Count is not exact.

This re-run can be avoided with this other coding:

Sub DeleteSpellingErrors()
    Dim cnt, i As Long
    Dim cur, Last As Range
    Dim doc As Document
    Set doc = ActiveDocument
    cnt = doc.Range.SpellingErrors.Count
    Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToFirst)
    Set Last = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToLast)
    i = 1
    Do While cur <> Last
        cur.Select
        cur.Delete
        Debug.Print cnt & " " & i
        Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToNext)
        DoEvents
        i = i + 1
    Loop
End Sub

For testing purposes the document consisted of 107 pages with more than 3000 spelling errors and it took few minutes (about 3 or 4) of execution.

This is another version, that needs just one run to delete all the spelling errors, for Graham Mayor's add-in:

Function DeleteSpellingErrors(doc As Document) As Boolean
    Dim cnt, i As Long
    Dim cur, Last As Range
    If doc Is Nothing Then
        Set doc = Application.ActiveDocument
    End If
    Do
        cnt = doc.Range.SpellingErrors.Count
        If cnt <= 0 Then Exit Do
        Set Last = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToLast)
        Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToFirst)
        For i = 1 To cnt
            cur.Select
            cur.Delete
            'Debug.Print cnt & " " & i
            Set cur = doc.GoTo(What:=wdGoToSpellingError, Which:=wdGoToNext)
            DoEvents
            i = i + 1
        Next
    Loop
    DeleteSpellingErrors = True
End Function