I have a code that Bernie Deitrick helped write for me. Now I need the pasted
text to reflect the orginal color. There can be several lines of text, all of
different colors, in the same cell.

Any guidance is greatly appreciated.

Sub UpdateWorksheets()

'Sheets(Array("Retail", "Community", "Workplace", "Corporate")).Select
'Sheets("Retail").Activate
'Application.Run "'2007 calendar.xls'!ClearCalendarSheets"


Dim i As Integer
Dim myCell As Range

Dim Erase1 As Boolean
Dim Erase2 As Boolean
Dim Erase3 As Boolean
Dim Erase4 As Boolean
Dim Erase5 As Boolean
Dim Erase6 As Boolean
Dim Erase7 As Boolean

For Each myCell In Worksheets("2007 Master
Events").Range("B5:H9,B14:H18,B23:H28,B33:H37,B42: H46,B51:H56,B61:H65,B70:H74,B79:H83,B88:H92,B97:H1 01,B106:H110")

Erase1 = True
Erase2 = True
Erase3 = True
Erase4 = True
Erase5 = True
Erase6 = True
Erase7 = True

For i = 1 To Len(myCell.Value)
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = -4105 Then
If Erase1 = True 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 Erase2 = True Then
Worksheets("Retail").Range(myCell.Address).ClearCo ntents
Erase2 = False
End If
Worksheets("Retail").Range(myCell.Address).Value = _
Worksheets("Retail").Range(myCell.Address).Value & Mid(myCell.Value,
i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 11 Then
If Erase3 Then
Worksheets("Community").Range(myCell.Address).Clea rContents
Erase3 = False
End If
Worksheets("Community").Range(myCell.Address).Valu e = _
Worksheets("Community").Range(myCell.Address).Valu e &
Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 10 Then
If Erase4 Then
Worksheets("Workplace").Range(myCell.Address).Clea rContents
Erase4 = False
End If
Worksheets("Workplace").Range(myCell.Address).Valu e = _
Worksheets("Workplace").Range(myCell.Address).Valu e &
Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.FontStyle = "Bold" Then
If Erase5 Then
Worksheets("LA Bold").Range(myCell.Address).ClearContents
Erase5 = False
End If
Worksheets("LA Bold").Range(myCell.Address).Value = _
Worksheets("LA Bold").Range(myCell.Address).Value & Mid(myCell.Value,
i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.FontStyle = "Italic" Then
If Erase6 Then
Worksheets("Durham Italic").Range(myCell.Address).ClearContents
Erase6 = False
End If
Worksheets("Durham Italic").Range(myCell.Address).Value = _
Worksheets("Durham Italic").Range(myCell.Address).Value &
Mid(myCell.Value, i, 1)
End If

If myCell.Characters(Start:=i, Length:=1).Font.FontStyle = "Bold Italic"
Then
If Erase7 Then
Worksheets("DC Bold Italic").Range(myCell.Address).ClearContents
Erase7 = False
End If
Worksheets("DC Bold Italic").Range(myCell.Address).Value = _
Worksheets("DC Bold Italic").Range(myCell.Address).Value &
Mid(myCell.Value, i, 1)
End If

Next i
Next myCell
MsgBox "All sheets have been updated!"
End Sub
--
Thank you,

scrowley(AT)littleonline.com