vba to correct spelling mistakes of words using wildcards

[cjcass]

I have the code below that corrects spelling mistakes in Col.I on Sheet1 based on criteria in a two column table located at W6:X# on Sheet10.

In column W on Sheet10 each cell has a letter/wildcard combination (eg. c*m*c*n) and next to each of these in adjacent cells there are words in column X (eg. communication) which represent correct spellings.

The cells in Col.I on Sheet1 contain text as phrases, eg. 'his communiccation was very poor'. The words in the phrases will vary in terms of their case, so cases should not be matched during the vba's search and the phrases vary in number of words.

The code below changes misspelt words to the word that corresponds in Sheet10 Column X but only if the word is the only word in the cell.

How can I tailor this code so it finds and corrects words that are part of a phrase in a cell?

It would be an added benefit if any corrected words could be highlighted in bold red so I can easily spot the changes after they've been made (this would be a nice to have but not essential).

Of course please feel free to ask any questions if you need more scoping for this, thanks.

Any help much appreciated.

Dim LRow As Long, i As Long
Dim varSearch As Variant

With Sheet10
    LRow = .Cells(.Rows.Count, 23).End(xlUp).Row '23 relates to Col W
    varSearch = .Range("W6:X" & LRow)
End With

With Sheet1.Range("I:I")
    For i = LBound(varSearch) To UBound(varSearch)
        .Replace what:=varSearch(i, 1), replacement:=varSearch(i, 2), lookat:=xlWhole
    Next
End With

 

[PeteWright]

Here's a little program I wrote:

The Worksheets:

MrExcel_cjcass_wcsr.xlsm
	I
1
2	his comunicon was very poor
3
4	her communication was good
5	their comicton was ok
6
7	this is only a tets
8	this is olny a tets
9
10	qwertz
11	the doors are alwas open
12	paralel universe
13	this is not necesary
14	this is not neccesary
15	that's unbelievabel
16	qw asdf er asdf tz
17
Sheet1

MrExcel_cjcass_wcsr.xlsm
	W	X
6	c.*m.*c.*n	communication
7	tets	test
8	olny	only
9	qwertz	qwerty
10	alwas	always
11	paralel	parallel
12	nec+es+ary	necessary
13	unbel.*vab(el|le)+	unbelievable
14	asdf	xyz
15
Sheet10

The Code:

Option Explicit

Sub CorrectSpelling()
   'Dim a As Integer, b As Integer, c As Integer, k As Integer, l As Integer, n As Integer, x As Integer
   'Dim cel As Range, tmp As Integer, arr() As Integer
   Dim WLength As Long, WLast As Long, XLength As Long, XLast As Long
   Dim answer As Integer
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Sheets("Sheet10")

   WLength = ws.Range("W6:W1048576").Cells.SpecialCells(xlCellTypeConstants).count
   XLength = ws.Range("X6:X1048576").Cells.SpecialCells(xlCellTypeConstants).count
   WLast = ws.Cells(Rows.count, 23).End(xlUp).Row
   XLast = ws.Cells(Rows.count, 24).End(xlUp).Row
   
   If (WLength <> XLength Or WLast <> XLast) Then
      answer = MsgBox("Inconsistent data in Dictionary. Errors may occur!" & vbCrLf & "Do you want to Continue?", vbQuestion + vbYesNo)
      If answer = vbNo Then Exit Sub
   End If
      
   Dim LastRowInColumn As Long
   LastRowInColumn = ThisWorkbook.Sheets("Sheet1").Cells(Rows.count, 9).End(xlUp).Row
   Dim i As Long, j As Long
   Dim Str As String
   Dim Max As Long
   Dim Pat As String
   Dim Rep As String
   Max = Application.WorksheetFunction.Max(WLast, XLast)
   
   For i = 1 To LastRowInColumn
      For j = 6 To Max
         Str = ThisWorkbook.Sheets("Sheet1").Cells(i, 9).Value2
         If Str = "" Then Exit For
         Pat = ThisWorkbook.Sheets("Sheet10").Cells(j, 23).Value2
         Rep = ThisWorkbook.Sheets("Sheet10").Cells(j, 24).Value2
         ThisWorkbook.Sheets("Sheet1").Cells(i, 9).Value = WildCardSearchReplace(Str, Pat, Rep)
      Next j
   Next i
End Sub

Function WildCardSearchReplace(Str As String, Pat As String, Rep As String) As String
   Dim RegExPattern As String, RegExReplace As String
   Dim RegExObject As Object
   Set RegExObject = CreateObject("VBScript.RegExp")
   RegExObject.IgnoreCase = True
   RegExObject.Global = True
   RegExObject.Pattern = Pat
   RegExReplace = Rep
   WildCardSearchReplace = RegExObject.replace(Str, RegExReplace)
End Function

I tried to figure out the coloring thing, but that seems a little tricky. I mean, I know how to change the letters to bold red, but each time a word is formatted in a loop, the previous format gets cleared.

I put this after the second loop end (after 'Next j'), but it doesn't work. Maybe someone else will find a solution for that.

Set cel = ThisWorkbook.Sheets("Sheet1").Cells(i, 9)
k = 1 : x = -1
Do While k < Len(Str) Or x <> 0
   l = Len(Rep)
   x = InStr(k, cel.Value2, Rep)
   If x = 0 Then Exit Do
   cel.Characters(x, l).Font.ColorIndex = 3
   cel.Characters(x, l).Font.Bold = True
   k = x + l
Loop

Maybe you noticed the different notation of the search patterns with wildcards. These are Regular Expressions.

Try the code and please let me know if it works.

 

[cjcass]

Here's a little program I wrote:

The Worksheets:

MrExcel_cjcass_wcsr.xlsm
	I
1
2	his comunicon was very poor
3
4	her communication was good
5	their comicton was ok
6
7	this is only a tets
8	this is olny a tets
9
10	qwertz
11	the doors are alwas open
12	paralel universe
13	this is not necesary
14	this is not neccesary
15	that's unbelievabel
16	qw asdf er asdf tz
17
Sheet1

MrExcel_cjcass_wcsr.xlsm
	W	X
6	c.*m.*c.*n	communication
7	tets	test
8	olny	only
9	qwertz	qwerty
10	alwas	always
11	paralel	parallel
12	nec+es+ary	necessary
13	unbel.*vab(el|le)+	unbelievable
14	asdf	xyz
15
Sheet10

The Code:

Option Explicit

Sub CorrectSpelling()
   'Dim a As Integer, b As Integer, c As Integer, k As Integer, l As Integer, n As Integer, x As Integer
   'Dim cel As Range, tmp As Integer, arr() As Integer
   Dim WLength As Long, WLast As Long, XLength As Long, XLast As Long
   Dim answer As Integer
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Sheets("Sheet10")

   WLength = ws.Range("W6:W1048576").Cells.SpecialCells(xlCellTypeConstants).count
   XLength = ws.Range("X6:X1048576").Cells.SpecialCells(xlCellTypeConstants).count
   WLast = ws.Cells(Rows.count, 23).End(xlUp).Row
   XLast = ws.Cells(Rows.count, 24).End(xlUp).Row
  
   If (WLength <> XLength Or WLast <> XLast) Then
      answer = MsgBox("Inconsistent data in Dictionary. Errors may occur!" & vbCrLf & "Do you want to Continue?", vbQuestion + vbYesNo)
      If answer = vbNo Then Exit Sub
   End If
     
   Dim LastRowInColumn As Long
   LastRowInColumn = ThisWorkbook.Sheets("Sheet1").Cells(Rows.count, 9).End(xlUp).Row
   Dim i As Long, j As Long
   Dim Str As String
   Dim Max As Long
   Dim Pat As String
   Dim Rep As String
   Max = Application.WorksheetFunction.Max(WLast, XLast)
  
   For i = 1 To LastRowInColumn
      For j = 6 To Max
         Str = ThisWorkbook.Sheets("Sheet1").Cells(i, 9).Value2
         If Str = "" Then Exit For
         Pat = ThisWorkbook.Sheets("Sheet10").Cells(j, 23).Value2
         Rep = ThisWorkbook.Sheets("Sheet10").Cells(j, 24).Value2
         ThisWorkbook.Sheets("Sheet1").Cells(i, 9).Value = WildCardSearchReplace(Str, Pat, Rep)
      Next j
   Next i
End Sub

Function WildCardSearchReplace(Str As String, Pat As String, Rep As String) As String
   Dim RegExPattern As String, RegExReplace As String
   Dim RegExObject As Object
   Set RegExObject = CreateObject("VBScript.RegExp")
   RegExObject.IgnoreCase = True
   RegExObject.Global = True
   RegExObject.Pattern = Pat
   RegExReplace = Rep
   WildCardSearchReplace = RegExObject.replace(Str, RegExReplace)
End Function

I tried to figure out the coloring thing, but that seems a little tricky. I mean, I know how to change the letters to bold red, but each time a word is formatted in a loop, the previous format gets cleared.

I put this after the second loop end (after 'Next j'), but it doesn't work. Maybe someone else will find a solution for that.

Set cel = ThisWorkbook.Sheets("Sheet1").Cells(i, 9)
k = 1 : x = -1
Do While k < Len(Str) Or x <> 0
   l = Len(Rep)
   x = InStr(k, cel.Value2, Rep)
   If x = 0 Then Exit Do
   cel.Characters(x, l).Font.ColorIndex = 3
   cel.Characters(x, l).Font.Bold = True
   k = x + l
Loop

Maybe you noticed the different notation of the search patterns with wildcards. These are Regular Expressions.

Try the code and please let me know if it works.

Hi PeteWright,
Firstly, many thanks for your time and help with this.
The code works well with your examples, however I tried it with further examples and it didn't play in the same way.
For example:
effective comminicatun gives effecommunication as a result and
this is the comunication channel gives this is the communicationel as the result
Any further help you can give would be much appreciated.
Regards,
cjcass