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

If I wanted to do that I would use something like this:

Sub clrcont()
Sheets(1).Range("B2").Copy
Sheets(2).Range("D2").PasteSpecial Paste:=xlValues
Sheets(2).Range("D2").PasteSpecial Paste:=xlFormats
MsgBox "Look"
Application.CutCopyMode = False
Cells.Clear
End Sub

The format and values do not interfere with each other in the
paste execution. You can also do this with a formula in B2 and
the formula will not be pasted but the value and color will. The
only drawback to this method is that if you have borders on
the source cell and do not want them on the destination cell, you
would have to remove them after the paste action.

"Les" wrote:

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