Solved: Bold Text From a Defined Word to End of Line

[007]

Excel 2007
I have a marco that I found online that will bold and color a text string in a worksheet. It works great but I would like to modify it so that it will bold and color not only the defined text string but the remaining string on that text line. I have a spreadsheet that I want to bold/color "Serial Number:#####" where the ##### length is not always a constant number of characters. So search the sheet for "Serial Number" and bold/color "Serial Number" and any remaining characters on that line until the line breaks to the next line withing the cell.

Here is the code:
[VBA]Sub Bold_and_Color()
'USE-COLOR AND BOLD TEXT STRINGS WITHIN TEXT EXCEL VBA
'************************* DEC VARS *******************************
Dim myCell As Range
Dim myRng As Range
Dim FirstAddress As String
Dim iCtr As Long
Dim letCtr As Long
Dim startrow As Long 'BEGINNING OF RANGE
Dim endrow As Long ' END OF RANGE
Dim startcolumn As Integer 'BEGINNING COLUMN
Dim endcolumn As Integer 'END COLUMN
'************************* SET VALUES*****************************
'DUMMY VALUES - COULD BE PASSED
startrow = 1
endrow = 500
startcolumn = 1
endcolumn = 200
'SET UP RANGE YOU ARE COLORING AND BOLDING -YOU COULD MODIFY TO PASS VALUE TO
Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))
'SET UP ARRAY WITH WORDS YOU WANT TO COLOR AND BOLD - YOU COULD PUSH VALUES FROM A LISTBOX TO THIS ARRAY
myWords = Array("Serial Number")
'BEGIN MASTER LOOP---------------------------------------
For iCtr = LBound(myWords) To UBound(myWords)
'ERROR FOUND-BYPASS
On Error Resume Next
With myRng
Set myCell = .Find(What:=myWords(iCtr), After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'LOGIC CHECK
If Not myCell Is Nothing Then
FirstAddress = myCell.Address
Do
For letCtr = 1 To Len(myCell.Value)
If StrComp(Mid(myCell.Value, letCtr, _
Len(myWords(iCtr))), _
myWords(iCtr), vbTextCompare) = 0 Then
myCell.Characters(Start:=letCtr, _
Length:=Len(myWords(iCtr))) _
.Font.ColorIndex = 5
End If
Next letCtr
For letCtr = 1 To Len(myCell.Value)
If StrComp(Mid(myCell.Value, letCtr, _
Len(myWords(iCtr))), _
myWords(iCtr), vbTextCompare) = 0 Then
myCell.Characters(Start:=letCtr, _
Length:=Len(myWords(iCtr))) _
.Font.FontStyle = "Bold"
End If
Next letCtr
'GET NEXT ADDRESS
Set myCell = .FindNext(myCell)
Loop While Not myCell Is Nothing _
And myCell.Address <> FirstAddress
End If
End With
Next iCtr
End Sub[/VBA]

[shrivallabha]

Welcome to VBAX. Here is one way of doing it. I've considered that Serial:#### will be at the beginning of the cell and you are entering some more data with ALT+ENTER syntax.
[VBA]Sub ChangeFormat()
Dim rTest As Range
Dim vData As Variant
Dim sAddress As String
With ActiveSheet
Set rTest = Cells.Find(What:="Serial", LookIn:=xlValues, Lookat:=xlPart, SearchDirection:=xlNext)
If rTest Is Nothing Then
MsgBox "There's no Cell with matching criteria!"
Else
sAddress = rTest.Address
Do
vData = Split(rTest, Chr(10))
With rTest.Characters(Start:=1, Length:=Len(vData(LBound(vData)))).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
End With
Set rTest = Cells.FindNext(rTest)
Loop While Not rTest Is Nothing And rTest.Address <> sAddress
End If
End With
End Sub
[/VBA]

[007]

What you posted Shrivallabha works for the first line of a cell, but the data it is not always the first line of a cell that contains the serial number, it varies on where it appears and the length varies, it could also have other words in front of the serial number for that particular line in the cell.

[007]

In the code I posted, is there a way to define myWords = Array("Serial Number") to include Serial Number with a wild card to the end of the line break?

[JimmyTheHand]

A modified version of Shrivallabha's code:
[vba]Sub ChangeFormat()
Dim rTest As Range, lBegin As Long, lEnd As Long
Dim sAddress As String
With ActiveSheet
Set rTest = Cells.Find(What:="Serial:", LookIn:=xlValues, Lookat:=xlPart, SearchDirection:=xlNext)
If rTest Is Nothing Then
MsgBox "There's no Cell with matching criteria!"
Else
sAddress = rTest.Address
Do
lBegin = InStr(rTest, "Serial:")
lEnd = InStr(lBegin, rTest, Chr(10))
With rTest.Characters(Start:=lBegin, Length:=lEnd - lBegin).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
End With
Set rTest = Cells.FindNext(rTest)
Loop While Not rTest Is Nothing And rTest.Address <> sAddress
End If
End With
End Sub[/vba]

[007]

SOLVED: You guys Rock! It WORKS!!! Thanks!