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!

 

[austinandrei]

The error is gone now.
Its okay and very thankful. I can wait for your codes as I know that this will really help a lot in the process.
The only problem now it the spacing issue where when the words in Column A has space inbetween, it will capture the one in the list in Column D with the space. This is just a guess I have for the data I executed.

 

[Dim Me as xlNoob]

Hey sorry I've been busy today. I'm actually getting a bit lost with this now, I think it's because of the small sets of test data. I seem to work something out for a small set of data and then try it with something else and it produces unacceptable results.

Here is what I'm up to so far, it is not satisfactory, but I haven't gotten my head around working with strings of multiple words. You may test it on your real world data but I don't think it will work very well. I'll keep fiddling with it and see if I come up with something better, in the mean time are you comfortable with sharing your real data or is there some sensitivity to it? If you can upload it to something like dropbox then I can access it and work with the full set of data to try and make better adjustments. Sorry this is taking a lot of effort.

Sub SpellCheck()
    Dim cell As Range, rng As Range
    Dim arrD() As Variant, arrM() As Single
    Dim chrMatch As Single, i As Long
    
    Range("B:C").Clear
    
    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
        ReDim arrM(1 To UBound(arrD))
        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 & " "
        wds% = Len(wd) - Len(WorksheetFunction.Substitute(wd, " ", ""))
        lastpos% = 0
        For w% = 1 To wds
            currwd$ = ""
            currwd = Mid(wd, lastpos + 1, InStr(lastpos + 1, wd, " ") - lastpos - 1)
            lastpos = InStr(1, wd, currwd) + Len(currwd)
            For i& = 1 To UBound(arrD)
                twd$ = arrD(i) & " "
                twds% = Len(twd) - Len(WorksheetFunction.Substitute(twd, " ", ""))
                tlastpos% = 0
                For k% = 1 To twds
                    tcurrwd$ = ""
                    tcurrwd = Mid(twd, tlastpos + 1, InStr(tlastpos + 1, twd, " ") - tlastpos - 1)
                    tlastpos = InStr(1, twd, tcurrwd) + Len(tcurrwd)
                    chrMatch! = 0
                    For j% = 1 To Len(currwd)
                        If InStr(1, tcurrwd, Mid(currwd, j, 1), vbTextCompare) Then
                            chrMatch = chrMatch + 1
                        End If
                    Next j
                    chrMatch = (chrMatch / Len(currwd)) * (WorksheetFunction.Min(Len(tcurrwd), chrMatch) / WorksheetFunction.Max(Len(tcurrwd), chrMatch))
                    arrM(i) = arrM(i) + (chrMatch * (w / k))
                Next k
            Next i
        Next w
        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

 

[sketharapu]

This is really helpful. I am using this code for my recent project. But facing few challenges like if I type "ABCD" which is completely different text from the list. This code is picking something from the list rather than ignoring it. Do we have any work around to it?

Thanks once again