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:
[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!

 

[austinandrei]

Hi Dim,
When I added HONDA, the ones with TOYOTA misspelled was tagged as HONDA until the 2nd capture for the above codes.
Then some NISSAN misspelled where tag to SEDAN.
The one with RED are the wrong taggings.
[TABLE="width: 453"]
<tbody>[TR]
[TD]Heading[/TD]
[TD][/TD]
[TD][/TD]
[TD]Heading[/TD]
[/TR]
[TR]
[TD]tyota[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[TD]nissan[/TD]
[/TR]
[TR]
[TD]tayota[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[TD]HONDA TMX[/TD]
[/TR]
[TR]
[TD]Nissan[/TD]
[TD][/TD]
[TD][/TD]
[TD]HONDA TC[/TD]
[/TR]
[TR]
[TD]nssan[/TD]
[TD]SEDAN[/TD]
[TD]nissan[/TD]
[TD]SEDAN[/TD]
[/TR]
[TR]
[TD]nsan[/TD]
[TD]SEDAN[/TD]
[TD]nissan[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]nisssan[/TD]
[TD]nissan[/TD]
[TD]SEDAN[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]nassin[/TD]
[TD]nissan[/TD]
[TD]SEDAN[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Honda Tmx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Honda Tc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]HONDA-TC[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]HONDA TCX[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]HONDA TC1[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]HONDA-TMX[/TD]
[TD]HONDA TMX[/TD]
[TD]HONDA TC[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]HONDA-TM[/TD]
[TD]HONDA TMX[/TD]
[TD]HONDA TC[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sedan 2015[/TD]
[TD]SEDAN[/TD]
[TD]Heading[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sedan 2014[/TD]
[TD]SEDAN[/TD]
[TD]Heading[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sdan[/TD]
[TD]SEDAN[/TD]
[TD]nissan[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[Dim Me as xlNoob]

Have you tried the code with your real data yet? Those examples that didn't match properly are very poorly spelled and your real data might not be as bad?

 

[austinandrei]

Sorry, I just noticed that I have deleted the "toyota" in column D that is why.
So the only one to check is the NISSAN misspelled that was tagged as SEDAN on Column B and was tagged now in Column C as NISSAN correctly.
[TABLE="class: cms_table, width: 453"]
<tbody>[TR]
[TD]nssan[/TD]
[TD]SEDAN[/TD]
[TD]nissan[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]nsan[/TD]
[TD]SEDAN[/TD]
[TD]nissan[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]nisssan[/TD]
[TD]nissan[/TD]
[TD]SEDAN[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]nassin[/TD]
[TD]nissan[/TD]
[TD]SEDAN[/TD]
[/TR]
</tbody>[/TABLE]

 

[austinandrei]

Hi Dim,
I'll get back to you once I'm in the office again and that would be after 3hrs from now.
Will update you once I tested on the real data.
Thanks a lot!

 

[Dim Me as xlNoob]

Ah yes I missed that Toyota was missing there, good catch. Have you tried on a backed up copy of your data to see what the results look like? I was actually thinking of limiting the second match to only appear when the first match is below an 80% match, that way you could filter out the blanks in column C so you can review all the most ambiguous results. I'm interested to see how many results from your real data will go to the second match.

 

[Dim Me as xlNoob]

I was actually thinking of limiting the second match to only appear when the first match is below an 80% match, that way you could filter out the blanks in column C so you can review all the most ambiguous results. I'm interested to see how many results from your real data will go to the second match.

I had a different idea of only including the second best match if it is within 20% of the first best match. This should limit your results in column C but also should focus more on the ambiguous matches (those that are within 20% of eachother).

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
        If WorksheetFunction.Max(arrM) - WorksheetFunction.Large(arrM, x) < 0.2 Then cell.Offset(0, 2) = correction2
skipcell:
    Next cell
End Sub

 

[austinandrei]

Hi Dim,
I got an error on this code and it stopped.
Error code "Overflow"

chrMatch = (chrMatch / Len(wd)) * (WorksheetFunction.Min(Len(arrD(i)), chrMatch) / WorksheetFunction.Max(Len(arrD(i)), chrMatch))

 

[Dim Me as xlNoob]

Are you able to tell me what the values were for chrMatch and i? when you enter debugging mode after the code finds an error if you hover your mouse over the variable it will display a tooltip with the variable's current value.

I have a feeling you may need to add this to the top of the code:

Dim i As Long

 

[austinandrei]

Hi Dim,
Just noticed, it completes the running for all items before the error.
So the variable went back to i=1.
The chrMatch = -1.#IND
I tried now with the real data but there's seems to be a problem when it comes to spacing like below:

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Heading[/TD]
[TD][/TD]
[TD][/TD]
[TD]Heading[/TD]
[/TR]
[TR]
[TD]toyata[/TD]
[TD]toyota[/TD]
[TD][/TD]
[TD]nissan[/TD]
[/TR]
[TR]
[TD]Toyota fortuner[/TD]
[TD]HONDA TMX[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TMX[/TD]
[/TR]
[TR]
[TD]toyota model[/TD]
[TD]HONDA TMX[/TD]
[TD]HONDA TC[/TD]
[TD]HONDA TC[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]SEDAN[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]toyota[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]House & Lot[/TD]
[/TR]
</tbody>[/TABLE]

 

[Dim Me as xlNoob]

Ahh ok it's because there are blanks in your list, which means the length of that cell is 0 and you can't divide by 0.

Try this:

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, i As Long
    
    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 cell.Value = "" Then GoTo skipcell
        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
        If WorksheetFunction.Max(arrM) - WorksheetFunction.Large(arrM, x) < 0.2 Then cell.Offset(0, 2) = correction2
skipcell:
    Next cell
End Sub

Also I noticed a couple of toyota cells there coming out as honda variants... I have idea on how to improve this but unfortunately can't do it until tomorrow.