S,

Try something like the code below. You need to replace each occurence of Name1, Name2, and Name3 in
the code - I could not figure out your color/name combinations from your reply....

HTH,
Bernie
MS Excel MVP


Sub TryNow()
Dim i As Integer
Dim myCell As Range

Dim Erase1 As Boolean
Dim Erase2 As Boolean
Dim Erase3 As Boolean
Dim Erase4 As Boolean

For Each myCell In Worksheets("2007 Calendar").Range("B5:H110")

Erase1 = True
Erase2 = True
Erase3 = True
Erase4 = True

For i = 1 To Len(myCell.Value)
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = -4105 Then
If Erase1 Then
Worksheets("Corporate").Range(myCell.Address).Clea rContents
Erase1 = False
End If
Worksheets("Corporate").Range(myCell.Address).Valu e = _
Worksheets("Corporate").Range(myCell.Address).Valu e & Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 3 Then
If Erase1 Then
Worksheets("Name1").Range(myCell.Address).ClearCon tents
Erase1 = False
End If
Worksheets("Name1").Range(myCell.Address).Value = _
Worksheets("Name1").Range(myCell.Address).Value & Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 50 Then
If Erase2 Then
Worksheets("Name2").Range(myCell.Address).ClearCon tents
Erase2 = False
End If
Worksheets("Name2").Range(myCell.Address).Value = _
Worksheets("Name2").Range(myCell.Address).Value & Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 41 Then
If Erase3 Then
Worksheets("Name3").Range(myCell.Address).ClearCon tents
Erase3 = False
End If
Worksheets("Name3").Range(myCell.Address).Value = _
Worksheets("Name3").Range(myCell.Address).Value & Mid(myCell.Value, i, 1)
End If

Next i
Next myCell

End Sub



"SCrowley" wrote in message
...
Option 2: Red line to the Red sheet. Green line to the Green sheet, I have
created a 'black text' sheet (default text) as well see code below.

If myCell.Font.ColorIndex = -4105 Then
Worksheets("Corporate").Range(myCell.Address).Valu e = myCell.Value
End If

All colored text (strings) will meet one of the criteria. It will be red,
green, blue or black. The text (strings) are usually multiple words and not
separated out by individual letters.
--
Thank you,

scrowley(AT)littleonline.com


"Bernie Deitrick" wrote:

S,

No, it doesn't answer my question. What data should be copied to the other sheets from cell B5?

Option 1: All four lines to all four sheets.

Option 2: Line one to the red sheet, line 2 to the green sheet, etc.

Will all text be colored, or just some words? and what to do with the default text?

HTH,
Bernie
MS Excel MVP


"SCrowley" wrote in message
...
Thank you, Bernie.

I'll try this solution. To answer your question:

Cell B5 has 4 lines:
Ln1 = Washington Post (in RED, hard return to next line);
Ln2 = Chicago Tribune (in GREEN, hard return to next line);
Ln3 = Charlotte Observer (in BLUE, hard return to next line);
Ln4 = Atlanta Constitution (in BLACK)

Each color represents a specific team. The Master Sheet houses all the teams
data and the team sheets represent only the data that corrolates with their
specified colored font.

Does this help?
--
Thank you,

scrowley(AT)littleonline.com


"Bernie Deitrick" wrote:

S,

Try this, which will look at font colors on a letter by letter basis. Note that if the string
is
100 characters long, all in color 3, then this will copy the information over 100 times. We
could
add controls to only do the copying once if this is really slow..... Also, I wasn't sure
what
you
meant by 'separate' - do you only want the words that are the specific color??

Sub CalColors2()
Dim myCell As Range
Dim i As Integer

For Each myCell In Worksheets("2007 Calendar").Range("B5:H110")
For i = 1 To Len(myCell.Value)
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 3 Then
Worksheets("Retail").Range(myCell.Address).Value = myCell.Value
End If
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 5 Then
Worksheets("Workplace").Range(myCell.Address).Valu e = myCell.Value
End If
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 10 Then
Worksheets("Community").Range(myCell.Address).Valu e = myCell.Value
End If
Next i
Next myCell

End Sub

HTH,
Bernie
MS Excel MVP


"SCrowley" wrote in message
...
Bernie,

I passed this on to the end user. Now they want to separate if there are
multiple colors in one cell. Can this same concept apply? If so, how would it
look for multiples?
--
Thank you,

scrowley(AT)littleonline.com


"Bernie Deitrick" wrote:

S,

The general strategy would be to use a macro - you will need to figure out the correct
colorindices
to use. (Hint: use the macro recorder while applying the font colors...)

Sub CalColors()
Dim myCell As Range

Worksheets("Sheet1").Range("C5:H110").ClearContent s
Worksheets("Sheet2").Range("C5:H110").ClearContent s
Worksheets("Sheet3").Range("C5:H110").ClearContent s
Worksheets("Sheet4").Range("C5:H110").ClearContent s

For Each myCell In Worksheets("Master").Range("C5:H110")
If myCell.Font.ColorIndex = 3 Then
Worksheets("Sheet1").Range(myCell.Address).Value = myCell.Value
End If
If myCell.Font.ColorIndex = 6 Then
Worksheets("Sheet2").Range(myCell.Address).Value = myCell.Value
End If
If myCell.Font.ColorIndex = 8 Then
Worksheets("Sheet3").Range(myCell.Address).Value = myCell.Value
End If
If myCell.Font.ColorIndex = 10 Then
Worksheets("Sheet4").Range(myCell.Address).Value = myCell.Value
End If
Next myCell

End Sub


--
HTH,
Bernie
MS Excel MVP


"SCrowley" wrote in message
...
I have the 2007 calendar (jan - dec) on one worksheet (master worksheet). The
text is colored depending on the team it applies to. Copied worksheet 1 to
become Worksheet 2, 3 and 4 (one for each team). Here is the ideal solution:

Worksheet 2 (team 1) If cells C5:H110 on Worksheet 1 contain text that is
RED, populate C5:H110 on Worksheet 2 with only RED text. Worksheet 3 (team 2)
If cells C5:H110 on Worksheet 1 contain text that is GREEN, populate C5:H110
on Worksheet 3 with only GREEN text. Worksheet 4 (team 3) If cells C5:H110 on
Worksheet 1 contain text that is BLUE, populate C5:H110 on Worksheet 4 with
only RED text.

--
Thank you,

scrowley(AT)littleonline.com