Autocorrect or Suggest Correction VBA (Misspell)

[austinandrei]

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:

toyota

tayota

tyota

nissann

nisan

nssan nissan

<tbody>
</tbody>

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!

 

[Dim Me as xlNoob]

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?

 

[austinandrei]

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.

 

[Dim Me as xlNoob]

Ok so I had some time to put together a little code which hopefully helps out:

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.

 

[austinandrei]

Hi Dim,
I'm having an error "Type Mismatch" for below 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:

marvlous

marlous

marvelous

marvelos

toyota

tayota

tyota

tayato

toyota

<tbody>
</tbody>

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!

 

[Dim Me as xlNoob]

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:

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:

A	B	C	D
tyota	Toyota		Toyota
nssan	Nissan		Marvelous
nisann	Nissan		Nissan
nissann	Nissan		Datsun
tayoda	Toyota		Mitsubishi
tayota	Toyota		Bugatti
tyota	Toyota		Lamborghini
tayato	Toyota		Ferrari
Toyota
Mitsubfshi	Mitsubishi
Bagetti	Bugatti
Lumargenni	Lamborghini
Ferrosi	Marvelous
dutsan	Datsun
fereri	Ferrari
lambourginni	Lamborghini
toyoda	Toyota
Nissan
Toyota
Toyota
Nissan
Mitsubishi

<tbody>
</tbody>

The entries down the bottom had random uppercase letters and they were normalized with a proper format.

 

[Dim Me as xlNoob]

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.

 

[Dim Me as xlNoob]

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.

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):

	A	B	C	D
1	tyota	Toyota		Toyota
2	nssan	Nissan		Marvelous
3	nisann	Nissan		Nissan
4	nissann	Nissan		Datsun
5	tayoda	Toyota		Mitsubishi
6	tayota	Toyota		Bugatti
7	tyota	Toyota		Lamborghini
8	tayato	Toyota		Ferrari
9	Toyota
10	Mitsubfshi	Mitsubishi
11	Bagetti	Bugatti
12	Lumargenni	Lamborghini
13	Ferrosi	Ferrari
14	dutsan	Datsun
15	fereri	Ferrari
16	lambourginni	Lamborghini
17	toyoda	Toyota
18	Nissan
19	Toyota
20	Toyota
21	Nissan
22	Mitsubishi
23	mistubhsi	Mitsubishi
24	nisn	Nissan
25	taytoya	Toyota
26	dootsan	Datsun
27	burgetti	Bugatti
28	lambugginni	Lamborghini
29	mevolous	Marvelous
30	marvolus	Marvelous
31	mervellous	Marvelous
32	marvellos	Marvelous
33	dartson	Datsun
34	tayotta	Toyota
35	nessin	Nissan
36	nessen	Nissan
37	borgati	Bugatti

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>

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.

 

[austinandrei]

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!

 

[Dim Me as xlNoob]

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.

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.