VB Formatting different colors/fontstyles in one cell

M

mp80237

Hi,

I have the following pulled in from Access to Excel and I need to have
it automatically format for a report. This is all in one cell

06Jun for This Many Minutes – High/Medium/Low□
1700-2240MDT/2300-0440GMT/0700-1240HKG/1100-1640SYDâ–¡
Description (can be a very long description up to 100 characters)

The first line up to the box character I want to be ‘regular’ color
index 21. Than on the second line I want the first section before the
slash to be ‘bold’, color index 21. Next section after thefirst
slash I want ‘bold’ color index 19. After second slash ‘bold’
color index 22. After 3rd slash ‘bold’ color index 18 length 15.
Everything after ‘regular’ color index 21. So I created below
before I knew the “first†line was going to be required, but it
will not work because the first line does not have a set amount of
characters like the second. The range for the first line can be
anywhere from 21 to 29 characters. Any ideas? *** FYI, it is not
letting me paste that box character in here because as you know it is
considered a "return" character. So I pasted in a symbol so you could
see what I was. Again all lines are actually in one cell. Here is my
original formula:

Sub Colors()

‘
‘
Dim cel As Range

For Each cel In ActiveSheet.Range("f1:f100")
If cel.Value <> "" Then
With Selection.Characters(Start:=1, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 21
End With

With Selection.Characters(Start:=16, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 19
End With

With Selection.Characters(Start:=31, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 22
End With

With Selection.Characters(Start:=46, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 18
End With

With Selection.Characters(Start:=60, Length:=155).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 21
End With
End If

Next cel

End Sub


Thank you so much for the help!!
 
M

Martin Fishlock

This code works for the specification given there is very little checking for
string lengths and I leave that for you to havea look at.

'-------------------------------------
Option Explicit

Sub colors_sub(cel As Range, c_start, c_end, font_name, font_bold,
font_size, color_index)
Dim c_length As Long
c_length = c_end - c_start + 1
With cel.Characters(Start:=c_start, Length:=c_length).Font
.Name = font_name
.Bold = font_bold
.Size = font_size
.ColorIndex = color_index
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With

End Sub
Sub Colors()

Dim cel As Range

Dim i As Long
Dim ptr_s As Long, ptr_e As Long
On Error Resume Next
For Each cel In ActiveSheet.Range("f1:f100")
For i = 1 To Len(cel.Value)
Debug.Print i, Asc(Mid(cel.Value, i, 1)), Mid(cel.Value, i, 1)
Next i

If cel.Value <> "" Then
' set all to be regular
colors_sub cel, 1, Len(cel.Value), "Arial", False, 10, 21

' line 1
ptr_s = 1
ptr_e = InStr(ptr_s, cel.Value, Chr(10), vbBinaryCompare) - 1
colors_sub cel, ptr_s, ptr_e - ptr_s + 1, "Arial", False, 10, 21
' line 2 : sect. 1
ptr_s = ptr_e + 2
ptr_e = InStr(ptr_s, cel.Value, "/", vbBinaryCompare) - 1
colors_sub cel, ptr_s, ptr_e, "Arial", True, 10, 21
' line 2 : sect. 2
ptr_s = ptr_e + 2
ptr_e = InStr(ptr_s, cel.Value, "/", vbBinaryCompare) - 1
colors_sub cel, ptr_s, ptr_e, "Arial", True, 10, 19
' line 2 : sect. 3
ptr_s = ptr_e + 2
ptr_e = InStr(ptr_s, cel.Value, "/", vbBinaryCompare) - 1
colors_sub cel, ptr_s, ptr_e, "Arial", True, 10, 22
' line 2 : sect. 4
ptr_s = ptr_e + 2
ptr_e = InStr(ptr_s, cel.Value, Chr(10), vbBinaryCompare) - 1
colors_sub cel, ptr_s, ptr_e, "Arial", True, 10, 18
' line 3 : this is set at the start
' ptr_s = ptr_e + 2
' ptr_e = Len(cel.Value)
' colors_sub cel, ptr_s, ptr_e, "Arial", True, 10, 18
End If
Next cel
End Sub
 
M

mp80237

It worked! Thank you so much for your help!


Hi,

I have the following pulled in from Access to Excel and I need to have
it automatically format for a report. This is all in one cell

06Jun for This Many Minutes – High/Medium/Low□
1700-2240MDT/2300-0440GMT/0700-1240HKG/1100-1640SYDâ–¡
Description (can be a very long description up to 100 characters)

The first line up to the box character I want to be ‘regular’ color
index 21. Than on the second line I want the first section before the
slash to be ‘bold’, color index 21. Next section after the first
slash I want ‘bold’ color index 19. After second slash ‘bold’
color index 22. After 3rd slash ‘bold’ color index 18 length 15.
Everything after ‘regular’ color index 21. So I created below
before I knew the “first†line was going to be required, but it
will not work because the first line does not have a set amount of
characters like the second. The range for the first line can be
anywhere from 21 to 29 characters. Any ideas? *** FYI, it is not
letting me paste that box character in here because as you know it is
considered a "return" character. So I pasted in a symbol so you could
see what I was. Again all lines are actually in one cell. Here is my
original formula:

Sub Colors()

‘
‘
Dim cel As Range

For Each cel In ActiveSheet.Range("f1:f100")
If cel.Value <> "" Then
With Selection.Characters(Start:=1, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 21
End With

With Selection.Characters(Start:=16, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 19
End With

With Selection.Characters(Start:=31, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 22
End With

With Selection.Characters(Start:=46, Length:=15).Font
.Name = "Arial"
.FontStyle = "bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 18
End With

With Selection.Characters(Start:=60, Length:=155).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 21
End With
End If

Next cel

End Sub


Thank you so much for the help!!
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro Error 1
Superscrpts in Excel 2007 Text boxes 0
How to add text box with macro attached 1
Page Setup not working in macro 1
Autofill Error 4
Floating Bar Chart 1004 error 0
changing font size of chart title 2
Button Problem 2

Top