Highlight cells containing words of a given type

[Raj]

In an earlier post:
http://groups.google.co.in/group/mi...g/browse_thread/thread/880c4966ae9e72ad?hl=en
I had sought help in extracting words containing capital letters and/
or numbers from cells in Column C to corresponding cells in Column D.
eg. Column C2 has the sentence "The TKRTC value in the 765TW field is
not the default.". I wanted Column D2 to have "TKRTC 765TW".
Ron Rosenfeld and Rick Rothstein had contributed with Regexp and non-
Regexp solutions on that occasion.
Now, instead of Column D, I would like cells in Column C containing
such words be filled with a certain color and the word(s) be
displayed in bold.
I would love to see both Regexp and non-Regexp versions of the vba
code for this.

Thanks in advance for all the help.
Raj

 

[Peter T]

Hi Raj,

Have a go with this -

Sub test2()
Dim rng As Range
Dim cell As Range

SampleData

On Error GoTo errExit

Set rng = Range("A1:A400")

Application.ScreenUpdating = False

rng.Interior.ColorIndex = xlNone
rng.Font.Bold = False

For Each cell In rng
FormatWordCaps cell
Next

errExit:
Application.ScreenUpdating = True
End Sub

Sub SampleData()
[a1] = "The TKRTC value in the 765TW field is not the default."
[a2] = "His code is CND8599, and pin is 2588."
[a3] = ""
[a4] = "No words in this line with all caps"

Range("A1:A4").Copy Range("A1:A400")
Range("A1:A4").Columns.AutoFit

End Sub

Function FormatWordCaps(cell As Range) As Long
Dim b As Boolean
Dim i As Long, j As Long, k As Long, n As Long
Dim s As String
Dim v
Dim ba() As Byte
Dim Words() As String

If Left$(cell.Formula, 1) = "=" Then Exit Function

s = cell.Value
If Len(s) = 0 Then Exit Function

Do
s = Replace(s, " ", " ")
n = InStr(n + 1, s, " ")
Loop Until n = 0

If Len(s) <> Len(cell) Then cell.Value = s

Words = Split(Replace(Replace(s, vbLf, " "), vbCr, " "))

ReDim pos(1 To Len(s))

n = 1
For i = 0 To UBound(Words)
If Words(i) = UCase(Words(i)) And Words(i) Like "[A-Z0-9]*" Then
ba = Words(i)
k = 0
For j = 0 To UBound(ba) Step 2
k = k + 1
If ba(j + 1) > 0 Then ba(j) = 0
Select Case ba(j)
Case 48 To 57, 65 To 90
'0 to 9, A to Z
Case Else ' probably punctuation
k = k - 1
Exit For
End Select
Next
pos(n) = k
End If
n = n + Len(Words(i)) + 1
Next

k = 0
For i = 1 To UBound(pos)
If pos(i) Then
k = k + 1
cell.Characters(i, pos(i)).Font.Bold = True
End If
Next

If k Then cell.Interior.ColorIndex = 36
FormatWordCaps = k
End Function

Regards,
Peter T

 

[Raj]

Hi Raj,

Have a go with this -

Sub test2()
Dim rng As Range
Dim cell As Range

SampleData

On Error GoTo errExit

Set rng = Range("A1:A400")

Application.ScreenUpdating = False

rng.Interior.ColorIndex = xlNone
rng.Font.Bold = False

For Each cell In rng
FormatWordCaps cell
Next

errExit:
Application.ScreenUpdating = True
End Sub

Sub SampleData()
[a1] = "The TKRTC value in the 765TW field is not the default."
[a2] = "His code is CND8599, and pin is 2588."
[a3] = ""
[a4] = "No words in this line with all caps"

Range("A1:A4").Copy Range("A1:A400")
Range("A1:A4").Columns.AutoFit

End Sub

Function FormatWordCaps(cell As Range) As Long
Dim b As Boolean
Dim i As Long, j As Long, k As Long, n As Long
Dim s As String
Dim v
Dim ba() As Byte
Dim Words() As String

If Left$(cell.Formula, 1) = "=" Then Exit Function

s = cell.Value
If Len(s) = 0 Then Exit Function

Do
s = Replace(s, " ", " ")
n = InStr(n + 1, s, " ")
Loop Until n = 0

If Len(s) <> Len(cell) Then cell.Value = s

Words = Split(Replace(Replace(s, vbLf, " "), vbCr, " "))

ReDim pos(1 To Len(s))

n = 1
For i = 0 To UBound(Words)
If Words(i) = UCase(Words(i)) And Words(i) Like "[A-Z0-9]*" Then
ba = Words(i)
k = 0
For j = 0 To UBound(ba) Step 2
k = k + 1
If ba(j + 1) > 0 Then ba(j) = 0
Select Case ba(j)
Case 48 To 57, 65 To 90
'0 to 9, A to Z
Case Else ' probably punctuation
k = k - 1
Exit For
End Select
Next
pos(n) = k
End If
n = n + Len(Words(i)) + 1
Next

k = 0
For i = 1 To UBound(pos)
If pos(i) Then
k = k + 1
cell.Characters(i, pos(i)).Font.Bold = True
End If
Next

If k Then cell.Interior.ColorIndex = 36
FormatWordCaps = k
End Function

Regards,
Peter T


In an earlier post:

http://groups.google.co.in/group/microsoft.public.excel.programming/b...

I had sought help in extracting words containing capital letters and/
or numbers from cells in Column C to corresponding cells in Column D.
eg. Column C2 has the sentence "The TKRTC value in the 765TW field is
not the default.". I wanted Column D2 to have "TKRTC 765TW".
Ron Rosenfeld and Rick Rothstein had contributed with Regexp and non-
Regexp solutions on that occasion.
Now, instead of Column D, I would like cells in Column C containing
such words be filled with a certain color and the word(s) be
displayed in bold.
I would love to see both Regexp and non-Regexp versions of the vba
code for this.

Thanks in advance for all the help.
Raj- Hide quoted text -

- Show quoted text -

Thanks Pete for the solution. It worked, but stopped after a few rows.
I will find out why.
In the meantime, exploring the regexp approach, I succeeded in making
the following code fill (interior.colorindex) cells containing one or
more matches:

Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("C1:C785")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
Next
End Sub

I am stuck here. I would like the matching words displayed in bold in
addition to the cell being filled with yellow color. Can anyone help,
preferably with the regexp approach as the code is less?

Thanks,
Raj

 

[Peter T]

It worked, but stopped after a few rows

Is that after a few rows of your own test data (it worked fine with 400 rows
of
the SamplData test as posted).

Remove the error handler by commenting the On error resume next

report the string in the cell that fails and which line the code has failed
on

Can anyone help,
preferably with the regexp approach as the code is less?

Possibly a bit less but I wouldn't have thought much less by the time you
include all your
objectives. Also unless you are quite familiar with Regexp it would probably
take you longer to work out how to make small changes.

But if you want to use regexp there should be enough in the examples your
other thread which you could adapt and incorporate into the function I
posted. Before doing that, try and work out what the function does as
written.

Regards,
Peter T

Thanks Pete for the solution. It worked, but stopped after a few rows.
I will find out why.
In the meantime, exploring the regexp approach, I succeeded in making
the following code fill (interior.colorindex) cells containing one or
more matches:

Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("C1:C785")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
Next
End Sub

I am stuck here. I would like the matching words displayed in bold in
addition to the cell being filled with yellow color. Can anyone help,
preferably with the regexp approach as the code is less?

Thanks,
Raj

 

[Raj]

It worked, but stopped after a few rows

Is that after a few rows of your own test data (it worked fine with 400 rows
of
the SamplData test as posted).

Remove the error handler by commenting the On error resume next

report the string in the cell that fails and which line the code has failed
on

Can anyone help,
preferably with the regexp approach as the code is less?

Possibly a bit less but I wouldn't have thought much less by the time you
include all your
objectives. Also unless you are quite familiar with Regexp it would probably
take you longer to work out how to make small changes.

But if you want to use regexp there should be enough in the examples your
other thread which you could adapt and incorporate into the function I
posted. Before doing that, try and work out what the function does as
written.

Regards,
Peter T

Thanks Pete for the solution. It worked, but stopped after a few rows.
I will find out why.
In the meantime, exploring the regexp approach, I succeeded in making
the following code fill (interior.colorindex) cells containing one or
more matches:

Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("C1:C785")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
Next
End Sub

I am stuck here. I would like the matching words displayed in bold in
addition to the cell being filled with yellow color. Can anyone help,
preferably with the regexp approach as the code is less?

Thanks,
Raj- Hide quoted text -

- Show quoted text -

Peter,

Thanks. It did work on the data generated by you using the Sampledata
proc. But for some reason stopped on my data after 10 or 15 rows.
As I already said, I will check later why that happened. (Maybe I did
something wrong).

But, I owe you bigger thanks for the part of your code using
"cell.characters" that helped me crack the problem of highlighting the
cells with matches AS WELL AS rendering the matches in Bold. I am
posting the revised code below:

Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("a1:a1786")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
For Each rspmatch In rsp
c.Characters(rspmatch.FirstIndex + 1, rspmatch.Length).Font.Bold =
True
Next
Next
End Sub

I had to add a "+1" in the "c.characters" line above to get it right.
Something to do with the match object starting at 0. Is that the right
way to do it or is there a better way?

Thanks once again.
Raj

 

[Raj]

Is that after a few rows of your own test data (it worked fine with 400 rows
of
the SamplData test as posted).

Remove the error handler by commenting the On error resume next

report the string in the cell that fails and which line the code has failed
on

Possibly a bit less but I wouldn't have thought much less by the time you
include all your
objectives. Also unless you are quite familiar with Regexp it would probably
take you longer to work out how to make small changes.

But if you want to use regexp there should be enough in the examples your
other thread which you could adapt and incorporate into the function I
posted. Before doing that, try and work out what the function does as
written.

Regards,
Peter T

Thanks Pete for the solution. It worked, but stopped after a few rows.
I will find out why.
In the meantime, exploring the regexp approach, I succeeded in making
the following code fill (interior.colorindex) cells containing one or
more matches:
Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("C1:C785")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
Next
End Sub
I am stuck here. I would like the matching words displayed in bold in
addition to the cell being filled with yellow color. Can anyone help,
preferably with the regexp approach as the code is less?
Thanks,
Raj- Hide quoted text -

- Show quoted text -

Peter,

Thanks. It did work on the data generated by you using the Sampledata
proc. But for some reason stopped on my data after 10 or 15 rows.
As I already said, I will check later why that happened. (Maybe I did
something wrong).

But, I owe you bigger thanks for the part of your code using
"cell.characters" that helped me crack the problem of highlighting the
cells with matches AS WELL AS rendering the matches in Bold. I am
posting the revised code below:

Sub HighlightCells()
Dim w As Worksheet, c As Range
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.IgnoreCase = False
regexp.Pattern = "\b[A-Z0-9]+\b"
Set rng = Worksheets("Sheet1").Range("a1:a1786")
For Each c In rng
Set rsp = regexp.Execute(c.Text)
If rsp.Count > 0 Then c.Interior.ColorIndex = 6 ' Yellow color
interior for cell
For Each rspmatch In rsp
c.Characters(rspmatch.FirstIndex + 1, rspmatch.Length).Font.Bold =
True
Next
Next
End Sub

I had to add a "+1" in the "c.characters" line above to get it right.
Something to do with the match object starting at 0. Is that the right
way to do it or is there a better way?

Thanks once again.
Raj- Hide quoted text -

- Show quoted text -

Peter,

Your code worked. I had referenced the range wrong.
I will be studying your code on splitting the string into an array of
words and then formatting the matching portions. It will help me in
reusing the code in other tasks.

Thanks.
Regards,

 

[Peter T]

I will be studying your code on splitting the string into an

array of words

I lifted that bit from one of Rick Rothstein's functions in your other
thread. Anyway, glad it sounds like you've got it all working.

Regards,
Peter T