Hello all, i am using the code below to get the color of the cell and then
color another cell the same color in a different workbook with no problem. My
problem is that i want to copy not only the color but the date that is in the
cell as well.

Any help would be greatly appreciated.


Function CellColorIndex(InRange As Range, Optional _
OfText As Boolean = False) As Integer
'
' This function returns the ColorIndex value of a the Interior
' (background) of a cell, or, if OfText is true, of the Font in the cell.
'
Application.Volatile True
If OfText = True Then
CellColorIndex = InRange(1, 1).Font.ColorIndex
Else
CellColorIndex = InRange(1, 1).Interior.ColorIndex
End If

End Function
================================================== ==
Sub ProjectStatus()
'
Application.DisplayAlerts = False
Dim LastRowParts As Variant, LastRowSummary As Variant, NumberBlanks As
Variant
Dim RowCount As Long, PartID As Variant, C As Variant, SumRowCount As
Variant, PartRowCount As Variant
Dim Tdate As String, scValue As String


myKTL = "90ZA0810"

Tdate = Date
Tdate = Format(Tdate, "dd mmm yyyy")

With Workbooks("Project status update.xls").Sheets("sheet1")
'Sheets("QUALITY PARTS")
LastRowParts = .Cells(Rows.Count, "C").End(xlUp).Row
End With

With Workbooks("RMT-Status-Report-" & myKTL & ".xls").Sheets(myKTL & "
SUMMARY")
LastRowSummary = .Cells(Rows.Count, "D").End(xlUp).Row
For SumRowCount = 19 To LastRowSummary
cellColour = 0
PartID = .Range("D" & SumRowCount)
If IsNumeric(PartID) Then
With Workbooks("Project status update.xls").Sheets("sheet1")
'Sheets("QUALITY PARTS")
NumberBlanks = 0
For PartRowCount = 1 To LastRowParts
If PartID = .Range("B" & PartRowCount) Then
cellColour = CellColorIndex(.Cells(PartRowCount, "H"))
End If
Next PartRowCount
End With
Else
With Workbooks("Project status update.xls").Sheets("sheet1")
'Sheets ("QUALITY PARTS")
NumberBlanks = 0
For PartRowCount = 1 To LastRowParts
If PartID = .Range("B" & PartRowCount) Then
cellColour = CellColorIndex(.Cells(PartRowCount, "H"))
End If
Next PartRowCount
End With
End If

If cellColour = 3 Then 'Tdate DateSerial(2008, 5, 1) Then '--- If
after project date ---
.Range("R" & SumRowCount).Interior.Color = RGB(255, 0, 0) '---Red
ElseIf cellColour = 4 Then
.Range("R" & SumRowCount).Interior.Color = RGB(0, 255, 0) '---
Green
ElseIf cellColour = 6 Then
.Range("R" & SumRowCount).Interior.Color = RGB(255, 255, 0) '---
Yellow
Else
.Range("R" & SumRowCount).Interior.Color = RGB(255, 255, 255)
'--- white
End If


Next SumRowCount
End With

--
Les