Autocorrect or Suggest Correction VBA (Misspell)

austinandrei

Board Regular
Joined
Jun 7, 2014
Messages
117
Hi,
Is there a way using VBA to have an auto-correct or suggested correction for misspelled words?
Like below if I have these in Column A:
[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]toyota[/TD]
[/TR]
[TR]
[TD]tayota[/TD]
[/TR]
[TR]
[TD]tyota[/TD]
[/TR]
[TR]
[TD]nissann[/TD]
[/TR]
[TR]
[TD]nisan[/TD]
[/TR]
[TR]
[TD]nssan
nissan[/TD]
[/TR]
</tbody>[/TABLE]
Then the auto-correct or suggested word will be placed in Column B. Above is just an example but not limited to. The VBA can still have items cannot be read but atleast minimize the possibilities of spacing, interchange of letters,etc. There are about hundreds of list not just the 2 words in RED (toyota and nissan).
Also, lets say I have the correct list of items in Column D.
Any vba code that could help will really be appreciated. Thanks a lot!
 
Last edited:

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Hi there,

I don't think there is any need for VBA. As far as I know excel already has an in-built spellchecker which when you run it will give you a list of suggested word based on best match from the dictionaries it is using. You said you have a list of all the correct spellings in column D? You can copy and paste that list into your custom dictionary. You can find the path to the custom dictionary in the proofing options of excel.

However, you said there are hundreds of lists to check? So maybe you don't want to be clicking through a new dialogue box for every misspelled word. You can still add the list of words to your custom dictionary and I can come up with a macro which drops the first suggestion to the misspelled word into column B next to it? Is that what you're after?
 
Upvote 0
Hi Dim,
Thanks for the reply. Unfortunately, my file is a consolidation of reports that came from different branches since years ago (from 2014) and I would need to consolidate items based on the list in Column D. But the problem is I cannot classify the items in Column A because of the misspelled words so I would need a macro to correct the spelling of those words that cannot be match in Column D. But it is over 30000 line items.

For the years forward, I was able to create a template and limit the inputs from users to avoid misspelled words. But I will have to do it manually for the previous years and that is my problem. :(
 
Last edited:
Upvote 0
Ok so I had some time to put together a little code which hopefully helps out:

Code:
Sub SpellCheck()
    Dim cell As Range, rng As Range
    Dim arrD() As Variant, arrM() As Variant
    Dim wd As String, correction As String, strD As String
    
    Set rng = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    arrD = Application.Transpose(rng)
    
    Set rng = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim arrM(1 To UBound(arrD))
    strD = "~" & Join(arrD, "~") & "~"
    For Each cell In rng
        If InStr(1, strD, "~" & cell.Value & "~", vbTextCompare) Then
            cell.Value = StrConv(cell.Value, vbProperCase)
            GoTo skipcell
        End If
        wd = cell.Value
        For i = 1 To UBound(arrD)
            chrMatch = 0
            For j = 1 To Len(wd)
                If InStr(1, arrD(i), Mid(wd, j, 1)) Then
                    chrMatch = chrMatch + 1
                End If
            Next j
            chrMatch = chrMatch / Len(wd)
            arrM(i) = chrMatch
        Next i
        correction = arrD(WorksheetFunction.Match(WorksheetFunction.Max(arrM), arrM, 0))
        cell.Offset(0, 1) = correction
skipcell:
    Next cell
End Sub

Please backup your data before testing this code because you can't really undo things that are done by code.

I've tested this on a small set of data with some terribly spelled words and it seemed to work fairly well. At the moment I have set it up so it drops the suggested correction in column B next to the misspelled word. It fetches the list of words you have in column D to use as a dictionary and then attempts to find the best match from the dictionary list. I cannot guarantee that it will work for everything, especially if there are multiple words in the dictionary list which contain all the same characters or almost the same. I could add the second best match into column C or something. You may need to adjust the ranges that this code looks at to suit your needs.

Also if a word is spelled correctly but has random CAPS in it or something it will just convert it to Proper format.

Hope this helps you out, let me know how it goes and if you need more assistance.
 
Last edited:
Upvote 0
Hi Dim,
I'm having an error "Type Mismatch" for below code:
Code:
    arrD = Application.Transpose(rng)
Not sure if this is because of being in Excel 2007? Though I will be migrating to Excel 2013 by nextweek.
My samples from Cells A1 to A9 are below:
[TABLE="width: 72"]
<tbody>[TR]
[TD]marvlous[/TD]
[/TR]
[TR]
[TD]marlous[/TD]
[/TR]
[TR]
[TD]marvelous[/TD]
[/TR]
[TR]
[TD]marvelos[/TD]
[/TR]
[TR]
[TD]toyota[/TD]
[/TR]
[TR]
[TD]tayota[/TD]
[/TR]
[TR]
[TD]tyota[/TD]
[/TR]
[TR]
[TD]tayato[/TD]
[/TR]
[TR]
[TD]toyota[/TD]
[/TR]
</tbody>[/TABLE]
And my correct list on Cell D1 to D2 is "marvelous" & "toyota".
I just put all the codes in Module 1 and run the code and encounter this error.
Do I need to do something before running?
Thanks!
 
Last edited:
Upvote 0
Right this is happening because I assumed there would be headings in columns A and D so I started the ranges from row 2. And because you only have two words in your correct list, it skipped one (because I assumed D1 would be a heading), meaning that line of code was trying to assign a single value to an array which it doesn't like to do apparently. I should have asked more questions instead of assuming.

If you will be using headings in your real data set then for this test data just add some headings in, otherwise if there will never be any headings you can use this code:

Code:
Sub SpellCheck()
    Dim cell As Range, rng As Range
    Dim arrD() As Variant, arrM() As Variant
    Dim wd As String, correction As String, strD As String
    
    Set rng = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    arrD = Application.Transpose(rng)
    
    Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim arrM(1 To UBound(arrD))
    strD = "~" & Join(arrD, "~") & "~"
    For Each cell In rng
        If InStr(1, strD, "~" & cell.Value & "~", vbTextCompare) Then
            cell.Value = StrConv(cell.Value, vbProperCase)
            GoTo skipcell
        End If
        wd = cell.Value
        For i = 1 To UBound(arrD)
            chrMatch = 0
            For j = 1 To Len(wd)
                If InStr(1, arrD(i), Mid(wd, j, 1)) Then
                    chrMatch = chrMatch + 1
                End If
            Next j
            chrMatch = chrMatch / Len(wd)
            arrM(i) = chrMatch
        Next i
        correction = arrD(WorksheetFunction.Match(WorksheetFunction.Max(arrM), arrM, 0))
        cell.Offset(0, 1) = correction
skipcell:
    Next cell
End Sub

And make sure your list of correct words is at least two words long. I can change the code to accept only one word into the dictionary, but I don't have time right now and I don't think you have a need for it.

I had success with the small set of test data you included, and here is a small set of test data I used:

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD="align: center"]A
[/TD]
[TD="width: 64, align: center"]B
[/TD]
[TD="width: 64, align: center"]C
[/TD]
[TD="width: 64, align: center"]D
[/TD]
[/TR]
[TR]
[TD]tyota
[/TD]
[TD="width: 64"]Toyota[/TD]
[TD="width: 64"][/TD]
[TD="width: 64"]Toyota[/TD]
[/TR]
[TR]
[TD="width: 90"]nssan[/TD]
[TD]Nissan
[/TD]
[TD][/TD]
[TD]Marvelous[/TD]
[/TR]
[TR]
[TD="width: 90"]nisann[/TD]
[TD]Nissan[/TD]
[TD][/TD]
[TD]Nissan
[/TD]
[/TR]
[TR]
[TD="width: 90"]nissann[/TD]
[TD]Nissan[/TD]
[TD][/TD]
[TD]Datsun[/TD]
[/TR]
[TR]
[TD="width: 90"]tayoda[/TD]
[TD]Toyota[/TD]
[TD][/TD]
[TD]Mitsubishi[/TD]
[/TR]
[TR]
[TD="width: 90"]tayota[/TD]
[TD]Toyota[/TD]
[TD][/TD]
[TD]Bugatti[/TD]
[/TR]
[TR]
[TD="width: 90"]tyota[/TD]
[TD]Toyota[/TD]
[TD][/TD]
[TD]Lamborghini[/TD]
[/TR]
[TR]
[TD="width: 90"]tayato[/TD]
[TD]Toyota[/TD]
[TD][/TD]
[TD]Ferrari[/TD]
[/TR]
[TR]
[TD="width: 90"]Toyota[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mitsubfshi[/TD]
[TD="colspan: 2"]Mitsubishi
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Bagetti[/TD]
[TD]Bugatti[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Lumargenni[/TD]
[TD="colspan: 2"]Lamborghini[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ferrosi[/TD]
[TD="colspan: 2"]Marvelous[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]dutsan[/TD]
[TD]Datsun[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fereri[/TD]
[TD]Ferrari[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]lambourginni[/TD]
[TD="colspan: 2"]Lamborghini[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]toyoda[/TD]
[TD]Toyota[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Nissan[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Toyota[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Toyota[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Nissan[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mitsubishi[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

The entries down the bottom had random uppercase letters and they were normalized with a proper format.
 
Last edited:
Upvote 0
I've just noticed that one of the entries has best matched Marvelous instead of Ferrari and I know why, I can improve the constraints for how it matches to other words and I'll post it up here for you.

Did you want me to add the second best match in column C for you? I doubt I will ever write a code which always 100% matches the right word.
 
Upvote 0
Alright! I've sorted something out for you which seems to be more accurate. I've tested with slightly more data (It's actually hard trying to come up with different terrible ways to spell a list of words).

So this code assumes you have no headings, so your list of misspelled words are in column A starting at row 1 and the list of correctly spelled words are in column D starting at row 1.

Code:
Sub SpellCheck()
    Dim cell As Range, rng As Range
    Dim arrD() As Variant, arrM() As Variant
    Dim wd As String, correction As String, strD As String
    Dim chrMatch As Single
    
    Set rng = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    If rng.Rows.Count = 1 Then
        ReDim arrD(1 To 1)
        arrD(1) = rng
    Else
        arrD = Application.Transpose(rng)
    End If
    
    Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim arrM(1 To UBound(arrD))
    strD = "~" & Join(arrD, "~") & "~"
    For Each cell In rng
        If InStr(1, strD, "~" & cell.Value & "~", vbTextCompare) Then
            cell.Value = StrConv(cell.Value, vbProperCase)
            GoTo skipcell
        End If
        wd = cell.Value
        For i = 1 To UBound(arrD)
            chrMatch = 0
            For j = 1 To Len(wd)
                If InStr(1, arrD(i), Mid(wd, j, 1), vbTextCompare) Then
                    chrMatch = chrMatch + 1
                End If
            Next j
            chrMatch = (chrMatch / Len(wd)) * (WorksheetFunction.Min(Len(arrD(i)), chrMatch) / WorksheetFunction.Max(Len(arrD(i)), chrMatch))
            arrM(i) = chrMatch
        Next i
        correction = arrD(WorksheetFunction.Match(WorksheetFunction.Max(arrM), arrM, 0))
        cell.Offset(0, 1) = correction
skipcell:
    Next cell
End Sub

And the set of data I've used to test (along with results in column B):

[TABLE="class: grid, width: 343, align: center"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]tyota[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD]Toyota[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]nssan[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD]Marvelous[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]nisann[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD]Nissan[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]nissann[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD]Datsun[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]tayoda[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD]Mitsubishi[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]tayota[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD]Bugatti[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]tyota[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD]Lamborghini[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]tayato[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD]Ferrari[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]Mitsubfshi[/TD]
[TD]Mitsubishi[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]Bagetti[/TD]
[TD]Bugatti[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]Lumargenni[/TD]
[TD]Lamborghini[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]Ferrosi[/TD]
[TD]Ferrari[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]dutsan[/TD]
[TD]Datsun[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]fereri[/TD]
[TD]Ferrari[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]16[/TD]
[TD]lambourginni[/TD]
[TD]Lamborghini[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]toyoda[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]18[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]19[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]20[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]21[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]22[/TD]
[TD]Mitsubishi[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]mistubhsi[/TD]
[TD]Mitsubishi[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]nisn[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]taytoya[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]26[/TD]
[TD]dootsan[/TD]
[TD]Datsun[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]27[/TD]
[TD]burgetti[/TD]
[TD]Bugatti[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD]lambugginni[/TD]
[TD]Lamborghini[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD]mevolous[/TD]
[TD]Marvelous[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]30[/TD]
[TD]marvolus[/TD]
[TD]Marvelous[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]31[/TD]
[TD]mervellous[/TD]
[TD]Marvelous[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]32[/TD]
[TD]marvellos[/TD]
[TD]Marvelous[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]33[/TD]
[TD]dartson[/TD]
[TD]Datsun[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]34[/TD]
[TD]tayotta[/TD]
[TD]Toyota[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]35[/TD]
[TD]nessin[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]36[/TD]
[TD]nessen[/TD]
[TD]Nissan[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]37[/TD]
[TD]borgati[/TD]
[TD]Bugatti[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]


Let me know if this does the trick? I'm happy to keep working it, I just need more data to test it with I guess.
 
Upvote 0
WOWWW!!!
Sorry,was not able to keep up with the time so I just saw the reply now AND THIS ACTUALLY WORKS!
Can't believe that a macro can be done with that :D
I always have the heading but your last code is not a problem because the Heading in Column A will be the same as the Heading in Column D (and is a unique one) that's why it still will works (so its like heading is being part of the list itself).
Yes, the second best match will do the last set of proofing the misspelled words but if you're busy I'm okay with the code above :D and have the second layer proofing manually. I believe this will already take most of the misspelled items.
Thanks a lot Dim!
 
Last edited:
Upvote 0
WOWWW!!!
Sorry,was not able to keep up with the time so I just saw the reply now AND THIS ACTUALLY WORKS!
Can't believe that a macro can be done with that :D
I always have the heading but your last code is not a problem because the Heading in Column A will be the same as the Heading in Column D (and is a unique one) that's why it still will works (so its like heading is being part of the list itself).
Yes, the second best match will do the last set of proofing the misspelled words but if you're busy I'm okay with the code above :D and have the second layer proofing manually. I believe this will already take most of the misspelled items.
Thanks a lot Dim!

No problem I was happy plugging away at it. Ok so I just added a couple of lines which places the second best match into column C, I haven't been able to test this properly and also you'll notice that the second best match can seem pretty stupid, but it may help with some fairly ambiguous words hopefully.

Code:
Sub SpellCheck()
    Dim cell As Range, rng As Range
    Dim arrD() As Variant, arrM() As Variant
    Dim wd As String, correction As String, strD As String, correction2 As String
    Dim chrMatch As Single
    
    Set rng = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    If rng.Rows.Count = 1 Then
        ReDim arrD(1 To 1)
        arrD(1) = rng
    Else
        arrD = Application.Transpose(rng)
    End If
    
    Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim arrM(1 To UBound(arrD))
    strD = "~" & Join(arrD, "~") & "~"
    For Each cell In rng
        If InStr(1, strD, "~" & cell.Value & "~", vbTextCompare) Then
            cell.Value = StrConv(cell.Value, vbProperCase)
            GoTo skipcell
        End If
        wd = cell.Value
        For i = 1 To UBound(arrD)
            chrMatch = 0
            For j = 1 To Len(wd)
                If InStr(1, arrD(i), Mid(wd, j, 1), vbTextCompare) Then
                    chrMatch = chrMatch + 1
                End If
            Next j
            chrMatch = (chrMatch / Len(wd)) * (WorksheetFunction.Min(Len(arrD(i)), chrMatch) / WorksheetFunction.Max(Len(arrD(i)), chrMatch))
            arrM(i) = chrMatch
        Next i
        correction = arrD(WorksheetFunction.Match(WorksheetFunction.Max(arrM), arrM, 0))
        x = 1
        Do
            x = x + 1
            correction2 = arrD(WorksheetFunction.Match(WorksheetFunction.Large(arrM, x), arrM, 0))
        Loop Until correction <> correction2
        cell.Offset(0, 1) = correction
        cell.Offset(0, 2) = correction2
skipcell:
    Next cell
End Sub

I really appreciate your feedback, I'm interested to hear how this goes for you.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top