问题
Hello I have been trying to figure out a code, so as to color different rows depending upon their task levels. I am new to VBA in MS Project. I have a code which I found online, but it only colors the text in the task column.
Sub ColorFormatOL()
Dim t As Task
Dim i As Integer
SelectTaskColumn
i = 0
For Each t In ActiveSelection.Tasks
If Not t Is Nothing Then
i = i + 1
If t.Summary Then
SelectRow row:=i, Columrowrelative:=False
Select Case t.OutlineLevel
Case 1
FontEx Color:=pjRed
Case 2
FontEx Color:=pjGreen
Case 3
FontEx Color:=pjTeal
End Select
End If
End If
Next t
End Sub
回答1:
I played around with the code a bit and found the answer :D
Sub ColorFormatOL()
Dim t As Task
Dim i As Integer
i = 1
For Each t In ActiveProject.Tasks
SelectRow row:=i, rowrelative:=False
Select Case t.OutlineLevel
Case 1
Font32Ex CellColor:=&HB37F15
Case 2
Font32Ex CellColor:=&HD6982E
Case 3
Font32Ex CellColor:=&HF6BE41
Case 4
Font32Ex CellColor:=&HF7D577
End Select
i = i + 1
Next t
End Sub
回答2:
Here's a macro I use:
Public Sub FormatOutline_Blue() Call FormatOutlineLevels(9851951, 14396046, 15189684, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215) End Sub Public Sub FormatOutline_Green() Call FormatOutlineLevels(4697456, 9293992, 11788485, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215) End Sub Public Sub FormatOutline_Aqua() Call FormatOutlineLevels(13998939, 15057820, 15652797, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215) End Sub Private Sub FormatOutlineLevels(level1 As String, level2 As String, level3 As String, level4 As String, level5 As String, level6 As String, level7 As String, level8 As String, level9 As String, Optional font1 As String) 'Format the outline levels. The macro filters to summary tasks, selects the entire sheet, shows outline level x, formats entire sheet. 'Next, it shows one outline level up (x - 1), formats entire sheet. 'Last, it removes formatting from inactive summary tasks. 'Prepare On Error GoTo ErrorHandler SaveOriginalSettings OutlineShowAllTasks FilterApply Name:="Summary Tasks" SelectSheet 'Format all rows, starting with this outline level OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel9 Font32Ex CellColor:=level9 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel8 Font32Ex CellColor:=level8 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel7 Font32Ex CellColor:=level7 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel6 Font32Ex CellColor:=level6 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel5 Font32Ex CellColor:=level5 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel4 Font32Ex CellColor:=level4 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel3 Font32Ex CellColor:=level3 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel2 Font32Ex CellColor:=level2 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel1 Font32Ex CellColor:=level1 If Len(font1) > 0 Then Font32Ex Color:=font1 'Remove formatting from inactive summary tasks ScreenUpdating = False OutlineShowAllTasks FilterEdit Name:="Inactive Summary Tasks", TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Summary", test:="equals", Value:="yes", ShowInMenu:=False, ShowSummaryTasks:=False FilterEdit Name:="Inactive Summary Tasks", TaskFilter:=True, FieldName:="", NewFieldName:="Active", test:="equals", Value:="no", Operation:="And", ShowSummaryTasks:=False FilterApply Name:="Inactive Summary Tasks" SelectSheet EditClearFormats ScreenUpdating = True 'Clean up FilterApply Name:="All Tasks" RestoreOriginalSettings CascadeOutline Exit Sub ErrorHandler: HandlingErrors End Sub Public Sub CascadeOutline() On Error Resume Next OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel9 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel8 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel7 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel6 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel5 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel4 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel3 OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel2 SelectRow Row:=1, rowrelative:=False On Error GoTo 0 End Sub Private Sub HandlingErrors() Select Case Err.Number Case 91 MsgBox "The first row you've selected is missing a task name.", vbCritical Case 424 MsgBox "The row you've selected may be missing a task name.", vbCritical Case 1100 MsgBox "This view and table combination doesn't have Outlines available. Try going to " & _ "View >> Data Group: Outline. If Outline is grayed out, try clicking on the task name." & _ vbNewLine & vbNewLine & "This error usually happens when the timeline or details pane is selected.", _ vbCritical, "Oops! Outline is Unavailable" Case 1101 MsgBox "Try using this macro on the Task Sheet view." & vbNewLine & vbNewLine & _ "Error#" & Str(Err.Number) & " - " & Err.Description, vbCritical, "Invalid View" Case Else MsgBox "Error#" & Str(Err.Number) & " - " & Err.Description & vbNewLine _ & "Line: " & Erl & vbNewLine _ , vbCritical End Select End Sub
来源:https://stackoverflow.com/questions/31154574/changing-background-row-color-according-to-task-levels-in-ms-project-vba