Automatically add a star icon based on color of the cell

[kre30a]

I have a timeline generator for project tracking (auto colors cells based on phases). For the Deploy phase, I have the cells colored green (this was all done in VBA, not conditional formatting). Now I want to place a star in the cells (centered in the cell) that represent the deploy phase (as well as the color): Here is what current code:

Sub RenderProjects()

Dim row, col
Dim t As String
Dim timelineRow
Dim lp
Dim startDate As Date
Dim endDate As Date
Dim startWeek, endWeek
Dim weekLp
Dim targetColor As Long

timelineRow = 4
row = 4
col = 1

While Worksheets("Projects").Cells(row, col).Value <> ""
t = Worksheets("Projects").Cells(row, 1).Value + Chr(10) + Worksheets("Projects").Cells(row, 2).Value + Chr(10) + Worksheets("Projects").Cells(row, 3).Value
Worksheets("Timeline").Cells(timelineRow, 1).Value = t
Worksheets("Timeline").Cells(timelineRow, 2).Value = Worksheets("Projects").Cells(row, 4).Value

t = Worksheets("Projects").Cells(row, 5).Value
If (t = Range("On_Track").Value) Then
targetColor = Range("On_Track").Interior.color
Worksheets("Timeline").Cells(timelineRow, 1).Interior.color = targetColor
End If
If (t = Range("At_Risk").Value) Then
targetColor = Range("At_Risk").Interior.color
Worksheets("Timeline").Cells(timelineRow, 1).Interior.color = targetColor
End If
If (t = Range("Off_Track").Value) Then
targetColor = Range("Off_Track").Interior.color
Worksheets("Timeline").Cells(timelineRow, 1).Interior.color = targetColor
End If
If (t = Range("Pending").Value) Then
targetColor = Range("Pending").Interior.color
Worksheets("Timeline").Cells(timelineRow, 1).Interior.color = targetColor

End If


col = 6
For lp = 1 To 8
t = Worksheets("Projects").Cells(row, 6 + (lp - 1) * 2).Value
If (t <> "") Then
startDate = Worksheets("Projects").Cells(row, 6 + (lp - 1) * 2).Value
endDate = Worksheets("Projects").Cells(row, 7 + (lp - 1) * 2).Value
startWeek = Application.WorksheetFunction.WeekNum(startDate)
endWeek = Application.WorksheetFunction.WeekNum(endDate)
targetColor = GetCategoryColor(lp)
For weekLp = startWeek To endWeek
Worksheets("Timeline").Cells(timelineRow, 4 + weekLp).Interior.color = targetColor
Next weekLp
End If


Next lp






timelineRow = timelineRow + 1
row = row + 1
Wend

End Sub


Function GetCategoryColor(ByVal lp As Integer) As Long

Dim PlanningColor As Long
Dim RequirementsColor As Long
Dim ArchColor As Long
Dim BuildColor As Long
Dim TestColor As Long
Dim UATColor As Long
Dim DeployColor As Long
Dim WarrantyColor As Long

' GRAB THE BACKGROUND COLORS FROM THE Projects SHEET TO COLOR CODE PROJECT STATES
PlanningColor = Range("PlanningColor").Interior.color
RequirementsColor = Range("RequirementsColor").Interior.color
ArchColor = Range("ArchColor").Interior.color
BuildColor = Range("BuildColor").Interior.color
TestColor = Range("TestColor").Interior.color
UATColor = Range("UATColor").Interior.color
DeployColor = Range("DeployColor").Interior.color
WarrantyColor = Range("WarrantyColor").Interior.color

Dim color

Select Case lp

Case 1
color = PlanningColor
Case 2
color = RequirementsColor
Case 3
color = ArchColor
Case 4
color = BuildColor
Case 5
color = TestColor
Case 6
color = UATColor
Case 7
color = DeployColor
Case 8
color = WarrantyColor
End Select

GetCategoryColor = color

End Function

[Bernie Deitrick]

Use code like the subroutine below, used by passing the cell of interest to it, like

Please Login or Register  to view this content.

Here is the code to use - the 10, 10 are the height and width, which you can adjust to get the size you want (but change the 5s too, which are half of 10):

Please Login or Register  to view this content.

[kre30a]

Where do I add

AddStar Worksheets("Timeline").Cells(timelineRow, 4 + weekLp)

[Bernie Deitrick]

When you add the green fill - not sure which is green, but if this is the green fill:

Please Login or Register  to view this content.

then it would become

Please Login or Register  to view this content.

[kre30a]

Did not work. Got a 400 error code and the star was placed on the projects sheet not the timeline sheet.

[Bernie Deitrick]

Are you running the macro with another sheet active?

[kre30a]

I just uploaded the workbook.

[Bernie Deitrick]

This should work....

[kre30a]

Thank you. I looked at it and the stars are appearing in the Architecture and Design filed (Arch) and they should appear in the Deploy fields. Additionally, when I render the timeline now, the columns appear to be off for some reason.

[Bernie Deitrick]

Sorry - I just picked a green color. Change the line

Please Login or Register  to view this content.

to

Please Login or Register  to view this content.

I don't do anything other than add stars, so I'm not sure what you mean by the columns being off. They didn't do anything when I ran the code - but you could always adjust the columns in code at the end of your macro.

[kre30a]

I figured it out. Thank you for your help. This works great!