Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Chriss Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Changing Text Color in Excel File Between Characters 1

Status
Not open for further replies.
Swi

Swi

Programmer
Joined
Feb 4, 2002
Messages
1,978
Location
US
What is the best method to change color between certain characters in each cell in Excel.

Code: 
This <is a> test

to

This [red]<is a>[/red] test

Thanks.

Swi
 
Sort by date Sort by votes
I only know of one method, using the Characters property of the Range (cell) method.

Say after you've determined starting point and length (using InStr()/InStrRev() functions?)

[tt]TheCell.Characters(6, 6).Font.Color = -16776961[/tt]

Roy-Vidar
 
Upvote 0 Downvote
Thanks.

Swi
 
Upvote 0 Downvote
BTW, have a star. If anyone is interested here is what I did. Note, I wrote it in VBScript as I do not have VB6 at work. Also, I did not add code to do multiple columns. It would just do the first column in a spreadsheet.

Code: 
========================================================
' Declare variables
'========================================================
Option Explicit
Dim fso, objExcel, objWorkbook, nRow, nCol, TotalCellLen, BegPos, EndPos, x
Dim InputFileName, OutputFileName
'========================================================
' Initializes FSO
'========================================================
Set fso = CreateObject("Scripting.FileSystemObject")
'========================================================
' Error checking for Input and Output files
'========================================================
Do
  InputFileName = Inputbox("Please enter your Input Excel File Name!","Enter Input Excel File Name")
  If fso.FileExists(InputFileName) = False then
    MsgBox "Please enter a valid Input File Name!", vbCritical
    InputFilename = ""
  End If
Loop Until Len(InputFilename) > 0
Do
  OutputFileName = InputBox("Please enter your Output Excel File Name!","Enter Output Excel File Name")
Loop Until Len(OutputFileName) > 0
'==============================================================
' Initializes Variables and checks to see if output file exists
'==============================================================
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open(InputFileName)
If fso.FileExists(OutputFileName) Then fso.DeleteFile(OutputFileName)
nRow = 1
nCol = 1
TotalCellLen = 0
BegPos = 0
EndPos = 0
'=================================================================
' Loops through the entire Excel file flagging fields in red
'=================================================================
Do Until Len(Trim(objExcel.Cells(nRow, nCol).Value)) = 0
    TotalCellLen = Len(objExcel.Cells(nRow, nCol).Value)
    For x = 1 To TotalCellLen
        If Mid(objExcel.Cells(nRow, nCol).Value, x, 1) = "<" Then
            BegPos = x
        ElseIf Mid(objExcel.Cells(nRow, nCol).Value, x, 1) = ">" Then
            EndPos = x + 1
            objExcel.Cells(nRow, nCol).Characters(BegPos, TotalCellLen - EndPos).Font.Color = vbRed
        Else
            objExcel.Cells(nRow, nCol).Characters(x, x).Font.Color = vbBlack
        End If
    Next
    nRow = nRow + 1
Loop
'========================================================
' Closes and clears all objects from memory
'========================================================
objWorkbook.SaveAs (OutputFileName)
objWorkbook.Close
objExcel.Application.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
'========================================================
' Prompts the user of completion
'========================================================
MsgBox "Done!"

Swi
 
Upvote 0 Downvote
The previous version of this had a bug in it so here is a correct version:

Code: 
'========================================================
' Declare variables
'========================================================
Option Explicit
Dim fso, objExcel, objWorkbook, nRow, nCol, BegPos, EndPos, x
Dim InputFileName, OutputFileName
'========================================================
' Initializes FSO
'========================================================
Set fso = CreateObject("Scripting.FileSystemObject")
'========================================================
' Error checking for Input and Output files
'========================================================
Do
  InputFileName = Inputbox("Please enter your Input Excel File Name!","Enter Input Excel File Name")
  If fso.FileExists(InputFileName) = False then
    MsgBox "Please enter a valid Input File Name!", vbCritical
    InputFilename = ""
  End If
Loop Until Len(InputFilename) > 0
Do
  OutputFileName = InputBox("Please enter your Output Excel File Name!","Enter Output Excel File Name")
Loop Until Len(OutputFileName) > 0
'==============================================================
' Initializes Variables and checks to see if output file exists
'==============================================================
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open(InputFileName)
If fso.FileExists(OutputFileName) Then fso.DeleteFile(OutputFileName)
nRow = 0
nCol = 0
BegPos = 0
EndPos = 0
'=================================================================
' Loops through the entire Excel file flagging fields in red
'=================================================================
For nRow = 1 To 100
  For nCol = 1 To 26
      For x = 1 To Len(objExcel.Cells(nRow, nCol).Value)
          If Mid(objExcel.Cells(nRow, nCol).Value, x, 1) = "<" Then
              BegPos = x
          ElseIf Mid(objExcel.Cells(nRow, nCol).Value, x, 1) = ">" Then
              EndPos = (x - BegPos) + 1
              objExcel.Cells(nRow, nCol).Characters(BegPos, EndPos).Font.Color = vbRed
          Else
              objExcel.Cells(nRow, nCol).Characters(x, 1).Font.Color = vbBlack
          End If
      Next
  Next
Next
'========================================================
' Closes and clears all objects from memory
'========================================================
objWorkbook.SaveAs (OutputFileName)
objWorkbook.Close
objExcel.Application.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
'========================================================
' Prompts the user of completion
'========================================================
MsgBox "Done!"

Swi
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

sal21
  • Locked
  • Question Question
CREATE msflexgrid as in xlsx file
Replies
8
Views
874
strongm
strongm
sal21
  • Locked
  • Question Question
Alternate row color in treeview
Replies
1
Views
721
strongm
strongm
sal21
  • Locked
  • Question Question
Check of valute change in text file
Replies
15
Views
1K
strongm
strongm
2009luca
  • Locked
  • Question Question
CHECK color of shape
Replies
5
Views
847
strongm
strongm
Ken01
  • Locked
  • Question Question
Areas under graphs and overlap areas between circles.
Replies
3
Views
1K
Ken01
Ken01

Part and Inventory Search

Sponsor

Back
Top