007
03-11-2011, 04:32 PM
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:
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
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:
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