Microsoft Projectでリソースごとにバーの色を変更する

これも標準で機能があっても良い気がしますが、ないのでマクロ化。

Sub Format_Style()
    ViewApply Name:="ガント チャート(&G)"
    Call SetBarColor(GetResourceColor)
End Sub


Private Function SetBarColor(Optional ByVal dcc As Object)
    Dim dicColorCode As Object
    If IsMissing(dcc) Then
        Set dicColorCode = GetResourceColorDefault
    Else
        If dcc Is Nothing Then
            Set dicColorCode = GetResourceColorDefault
        Else
            Set dicColorCode = dcc
        End If
    End If

' 色の割り当て処理
    Dim prj As Project
    Set prj = ActiveProject
    
    Dim num As Long
    num = prj.Tasks.Count
    
    Dim i As Long
    Dim resourceName As String
    For i = 1 To num
On Error GoTo Label1
        resourceName = prj.Tasks.Item(i).ResourceNames
        If resourceName <> "" Then
            If dicColorCode.Exists(resourceName) Then
                GanttBarFormat TaskID:=i, MiddleColor:=dicColorCode(resourceName), MiddlePattern:=3, LeftText:="開始日", RightText:="リソース名"
            End If
        End If
Label1:
    Next i
End Function





Private Function GetResourceColor() As Object
    Const PREFIX As String = "[["
    Const POSTFIX As String = "]]"
    Const IDENTIFIER As String = "color"

' カラーコードの取得
    Dim prj As Project
    Set prj = ActiveProject
    
    Dim num As Long
    num = prj.Resources.Count
    
    Dim i As Long, textStart As Long
    Dim posStart As Long, posEnd As Long
    Dim note As String
    Dim colorCode As String
    
    Dim dicColorCode As Object
    Set dicColorCode = CreateObject("Scripting.Dictionary")
    
    For i = 1 To num
        colorCode = ""
        note = prj.Resources.Item(i).Notes
        
        posStart = InStr(note, PREFIX)
        posEnd = InStr(note, POSTFIX)
        textStart = posStart + Len(IDENTIFIER) + 3
            
        If posStart Then
            colorCode = Mid(note, textStart, posEnd - textStart)
            
            If colorCode <> "" Then
                dicColorCode.Add prj.Resources.Item(i).Name, colorCode
            End If
        End If
    Next i
    
    If dicColorCode.Count > 0 Then
        Set GetResourceColor = dicColorCode
    Else
        Set GetResourceColor = Nothing
    End If
End Function

Private Function GetResourceColorDefault() As Object
' カラーコードの取得
    Const MAX_COLOR_CODE As Integer = 17
    
    Dim prj As Project
    Set prj = ActiveProject
    
    Dim num As Long
    num = prj.Resources.Count
    
    Dim i As Long
    
    Dim dicColorCode As Object
    Set dicColorCode = CreateObject("Scripting.Dictionary")
    
    For i = 1 To num
        dicColorCode.Add prj.Resources.Item(i).Name, i Mod MAX_COLOR_CODE
    Next i
    
    If dicColorCode.Count > 0 Then
        Set GetResourceColorDefault = dicColorCode
    Else
        Set GetResourceColorDefault = Nothing
    End If
End Function

Microsoft Project2007で動作を確認。 そもそも、あまり色を変える必要を感じない人も多いと思うけど、意外と便利なのでメモ。