タスク集計マクロ

 これは、Microsoft Projectから各種データを取得して、Microsoft Excelに書き出すマクロです。目的は、Projectのレベル3の粒度で進捗状況を把握するため、レベル3に従属するタスクの進捗情報等を集計することです。
(タスクにリソースを割り当ててあればこんな苦労はしなくても良いかも。。。)
 処理の概要は次の通りです。

 (1) クリア用シートに予め作成した雛形をアクティブなシートにコピーして、アクティブシートをクリアする。
 (2) Projectのレベル3に従属するタスク数を集計する。
 (3) Projectのタスクの指定した期日までの予定作業時間、実績作業時間、実際の達成率を抽出し、レベル3に集計する。
 (4) Excelでレベル1およびレベル2にそれぞれ従属するレベル3の予定作業時間等を集計する。
 (5) Excelで計算式をコピーする。

 このマクロは、シートを事前に準備する必要があるため、単にコピペで使えるというわけではありません。また、一応、自分で使用する範囲で動作確認は行っていますが、処理が完璧であることも保証しません。しかし、ネット上にMicrosoft Projectに関するマクロがほとんど落ちていないので、参考までに掲載しておきます。

' PV、基準作業時間/開始日等をMSPから取得し、タスク数・実PV等を計算してアクティブシートに転記
Sub ProjectからEVMデータをインポート()

   ' ********** 変数の定義 開始 **********
   Dim prj ' As New MSProject.Application
   Dim tasks ' As MSProject.tasks
   Dim task ' As MSProject.task

   Dim r As Integer, i As Integer
   Dim sh As Worksheet

   Dim EndDate As Variant ' 報告範囲の最終日+1
   Dim ReportDate As Variant ' 報告日+1

   Dim count As Integer ' タスク数のカウンタ
   Dim PlanCount As Integer ' 予定タスク数のカウンタ
   Dim FinishCount As Integer ' 実績タスク数のカウンタ
   Dim DelayCount As Integer ' 遅延タスク数のカウンタ

   Dim RowStart As Long ' 合計を計算する際の行の始点-1
   Dim RowStop As Long ' 合計を計算する際の行の終点+1
   Dim RowLimit As Long ' 最終行
   Dim ColTask As Long ' タスク名を転記する列番号

   Dim RepSmallThanFin As Integer ' 報告日<基準終了日
   Dim RepSmallThanStart As Integer ' 報告日<基準開始日
   Dim SpanFrStartToReport As Variant ' 基準開始日から報告日までの期間
   Dim SpanFrStartToFin As Variant ' 基準開始日から基準終了日までの期間

   ' EVVM指標関連
   Dim PlanedVal As Double
   Dim EffectPV As Double
   Dim SumPV As Double
   Dim SumEffPV As Double
   Dim EarnedVal As Double
   Dim SumEV As Double
   Dim ActualCost As Double
   Dim SumAC As Double

   ' タスク数関連
   Dim SumTaskNum As Long
   Dim SumPlanTaskNum As Long
   Dim SumActTaskNum As Long
   Dim SumDelTaskNum As Long

   ' タスクの直後にレベル1か2がある場合のフラグ
   Dim Lv1or2AfTask As Integer

   'シート名
   Dim TeamSheet As String
   ' ********** 変数の定義 終了 **********


   ' ********** 初期設定 開始 **********
   ' 画面更新OFF
   Application.ScreenUpdating = False

   ' 初期値設定(行数を指定するためのパラメータ)
   r = 2

   ' タスクを抽出する対象を決定する閾値
   ' 報告対象期間が変わった場合には変更する
   EndDate = 40026 ' 2009/08/01 0:00:00

   ' 遅延判断に利用する閾値
   ' 毎週の進捗報告のたびに更新する
   ReportDate = 39961 ' 2009/5/28 0:00:00

   ' 処理対象とする最終行
   RowLimit = 65536

   count = 0 ' カウンタのリセット
   PlanCount = 0 ' カウンタのリセット
   FinishCount = 0 ' カウンタのリセット
   DelayCount = 0 ' カウンタのリセット

   ' リセット
   SumPV = 0
   SumEffPV = 0
   SumEV = 0
   SumAC = 0
   ' ********** 初期設定 終了 **********


   ' ********** シートのクリア 開始 **********
   ' 「クリア用シート」の指定した範囲をコピーしアクティブなシートに貼り付ける

   'アクティブシート名取得
   TeamSheet = ActiveSheet.Name

   Call シートのクリア(TeamSheet, "クリア用シート", "A1:P65536")
   ' ********** シートのクリア 終了 **********


   ' ********** MSPから値の取得/集計 開始 **********
   ' MS-Projectのタスクを順番に見てサマリ行か否かを判断
   ' 必要に応じて、タスク名・基準作業時間・基準開始日などを取得
   ' レベル3以下のタスク数、実PVなどの集計を実行
   ' 条件に合致する場合は、直前のタスク群に対して集計した値をアクティブシートに転記
   ' 全体、レベル2に紐づくタスク数・PV等を合計

   ' オブジェクト型変数の代入
   Set prj = CreateObject("MSProject.Application")
   Set sh = ActiveSheet
   Set tasks = prj.ActiveProject.tasks

   ' MSPの全タスクを対象とする
   For i = 1 To tasks.count

      Set task = tasks(i)

      ' 報告範囲内のタスクのみ
      If task.BaselineStart < EndDate Then

         ' タスク名を転記する列番号はアウトラインレベルに依存させることでシートの転記先をずらす
         ColTask = task.OutlineLevel

         ' タスクがサマリ行の場合
         If task.Summary Then
            ' アウトラインレベルによる分岐
            If task.OutlineLevel > 0 And task.OutlineLevel < 4 Then

               ' 当該サマリ行の直前がタスク行か否かを判断
               ' これにより、冒頭の行に0が入るのを防止
               ' 直前がタスク行の場合
               If Lv1or2AfTask > 0 Then

                  ' 1つ手前のレベル3以下に属すタスク数・PV等をシートに転記する
                  ' サブプロシージャの呼び出し
                  Call 集計値の転記(TeamSheet, r, count, PlanCount, FinishCount, _
                                 DelayCount, SumPV, SumEffPV, SumEV, SumAC)

                  count = 0 ' カウンタのリセット
                  PlanCount = 0 ' カウンタのリセット
                  FinishCount = 0 ' カウンタのリセット
                  DelayCount = 0 ' カウンタのリセット

                  ' リセット
                  SumPV = 0
                  SumEffPV = 0
                  SumEV = 0
                  SumAC = 0

               End If

               sh.Cells(r, ColTask).Value = task.Name ' タスク名
               sh.Cells(r, 4).Value = task.BaselineStart ' 基準開始日
               sh.Cells(r, 5).Value = task.BaselineFinish ' 基準終了日

               r = r + 1

            End If

            ' リセット
            Lv1or2AfTask = 0

         'タスクがサマリ行ではない場合
         Else
            ' アウトラインレベル1〜3がタスク行の場合はタスク名等をアクティブシートに転記
            If task.OutlineLevel > 0 And task.OutlineLevel < 4 Then

               ' 直前のサマリ行が存在する場合は値をアクティブシートに転記
               If Lv1or2AfTask > 0 Then

                  ' 直前のレベル3以下に属すタスク数・PV等をシートに転記する
                  ' サブプロシージャの呼び出し
                  Call 集計値の転記(TeamSheet, r, count, PlanCount, FinishCount, _
                                 DelayCount, SumPV, SumEffPV, SumEV, SumAC)

                  count = 0 ' カウンタのリセット
                  PlanCount = 0 ' カウンタのリセット
                  FinishCount = 0 ' カウンタのリセット
                  DelayCount = 0 ' カウンタのリセット

                  ' リセット
                  SumPV = 0
                  SumEffPV = 0
                  SumEV = 0
                  SumAC = 0
               End If

               sh.Cells(r, ColTask).Value = task.Name ' タスク名
               sh.Cells(r, 4).Value = task.BaselineStart ' 基準開始日
               sh.Cells(r, 5).Value = task.BaselineFinish ' 基準終了日
               r = r + 1

            End If


            count = count + 1 ' タスク数のカウント

            ' タスク基準終了日が報告日より過去である場合
            If task.BaselineFinish < ReportDate Then
               PlanCount = PlanCount + 1 ' 計画タスク数のカウント
            End If

            ' 実際の達成率が100%である場合
            If task.PhysicalPercentComplete = 100 Then
               FinishCount = FinishCount + 1 ' 実績タスク数のカウント

            ' 実際の達成率が100%ではなく、タスク基準終了日が報告日より過去である場合
            ElseIf task.BaselineFinish < ReportDate Then
               DelayCount = DelayCount + 1 ' 遅延タスク数のカウント
            End If

            ' PV等を基準作業時間等から計算
            PlanedVal = task.BaselineWork / 60 / 8 ' PV
            EarnedVal = task.BaselineWork / 60 * task.PhysicalPercentComplete / 100 / 8 ' EV
            ActualCost = task.ActualWork / 60 / 8 ' AC

            ' 報告日が基準終了日より過去である場合
            If ReportDate < task.BaselineFinish Then
               RepSmallThanFin = 1
            Else
               RepSmallThanFin = 0
            End If

            ' 報告日が基準開始日より過去である場合
            If ReportDate < task.BaselineStart Then
               RepSmallThanStart = 1
            Else
               RepSmallThanStart = 0
            End If

            ' 作業期間
            SpanFrStartToFin = task.BaselineFinish - task.BaselineStart

            ' 報告日が基準開始日より過去である場合は、報告日までの作業期間は0
            If RepSmallThanStart = 1 Then
               SpanFrStartToReport = 0

            ' 報告日が基準開始日より未来で、かつ、
            ' 報告日が基準終了日より過去である場合は
            ' 報告日と基準開始日の差が作業期間
            ElseIf RepSmallThanFin = 1 Then
               SpanFrStartToReport = ReportDate - task.BaselineStart

            '報告日が基準開始日および基準終了日より未来である場合は
            ' 基準終了日と基準開始日の差が作業期間
            Else
               SpanFrStartToReport = SpanFrStartToFin
            End If

            ' 0/0の発散を防ぐための条件式
            If SpanFrStartToFin = 0 And SpanFrStartToReport = 0 Then
               EffectPV = 0
            Else
               EffectPV = PlanedVal * SpanFrStartToReport / SpanFrStartToFin
            End If

            ' サマリ下にあるタスクのPV等を集計
            SumPV = SumPV + PlanedVal
            SumEffPV = SumEffPV + EffectPV
            SumEV = SumEV + EarnedVal
            SumAC = SumAC + ActualCost

            ' サマリの識別に関するフラグ
            ' 冒頭のサマリを除外するためのもの
            Lv1or2AfTask = Lv1or2AfTask + 1

         End If
      End If
   Next i

   ' 上記ループ内では最終行の数値を転記できないので、
   ' ループ外で1回余分に処理を実行
   ' 直前のレベル3以下に属すタスク数・PV等をアクティブシートに転記
   Call 集計値の転記(TeamSheet, r, count, PlanCount, FinishCount, _
                  DelayCount, SumPV, SumEffPV, SumEV, SumAC)

   count = 0 ' カウンタのリセット
   PlanCount = 0 ' カウンタのリセット
   FinishCount = 0 ' カウンタのリセット
   DelayCount = 0 ' カウンタのリセット

   ' リセット
   SumPV = 0
   SumEffPV = 0
   SumEV = 0
   SumAC = 0
   ' ********** MSPから値の取得/集計 終了 **********


   ' ********** シート上での合計値計算 開始 **********
   ' レベル1・2に属するタスク数やPVなどの合計値を計算

   Call 合計値計算(TeamSheet)
   ' ********** シート上での合計値計算 終了 **********


   ' ********** シート上の計算式コピー 開始 **********
   ' アクティブなシートの2行目の計算式等を値のある行に対してコピー

   Call 計算式をコピー(TeamSheet)
   ' ********** シート上の計算式コピー 終了 **********


   ' ********** 終了処理 開始 **********
   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

   '画面更新ON
   Application.ScreenUpdating = True
   ' ********** 終了処理 終了 **********

End Sub

' クリア用シートの内容をコピー用シートにコピーし、コピー用シートをクリア
Sub シートのクリア(sSummarySheet As String, sClearSheet As String, sRange As String)

   '隠しワークシートであるクリア用シートの空シートをコピーしコピー用シートにペースト
   Worksheets(sClearSheet).Range(sRange).Copy
   Worksheets(sSummarySheet).Range(sRange).PasteSpecial

End Sub

' レベル3以下に属すタスク数・PV等を転記
Sub 集計値の転記(sSh As String, r As Integer, count As Integer, PlanCount As Integer, _
               FinishCount As Integer, DelayCount As Integer, SumPV As Double, _
               SumEffPV As Double, SumEV As Double, SumAC As Double)

   Dim sh As Worksheet ' シート


   ' ********** 条件ごとの値の転記 開始 **********
   ' オブジェクト型変数の代入
   Set sh = Worksheets(sSh)

   ' タスク数が0でなければその値をセルに代入
   If count <> 0 Then
      sh.Cells(r - 1, 7).Value = count ' タスク数
   Else
      sh.Cells(r - 1, 7).Value = 0 ' タスク数
   End If

   ' 計画タスク数が0でなければその値をセルに代入
   If PlanCount <> 0 Then
      sh.Cells(r - 1, 8).Value = PlanCount ' 計画タスク数
   Else
      sh.Cells(r - 1, 8).Value = 0 ' 計画タスク数
   End If

   ' 実績タスク数が0でなければその値をセルに代入
   If FinishCount <> 0 Then
      sh.Cells(r - 1, 9).Value = FinishCount ' 実績タスク数
   Else
      sh.Cells(r - 1, 9).Value = 0 ' 実績タスク数
   End If

   ' 遅延タスク数が0でなければその値をセルに代入
   If DelayCount <> 0 Then
      sh.Cells(r - 1, 10).Value = DelayCount ' 遅延タスク数
   Else
      sh.Cells(r - 1, 10).Value = 0 ' 遅延タスク数
   End If

   sh.Cells(r - 1, 13).Value = SumPV ' 直前のサマリに紐付くPVを転記
   sh.Cells(r - 1, 16).Value = SumEffPV ' 直前のサマリに紐付く実PVを転記
   sh.Cells(r - 1, 14).Value = SumEV ' 直前のサマリに紐付くEVを転記
   sh.Cells(r - 1, 15).Value = SumAC ' 直前のサマリに紐付くACを転記
   ' ********** 条件ごとの値の転記 終了 **********


   ' ********** 変数リセット 開始 **********
   count = 0 ' カウンタのリセット
   PlanCount = 0 ' カウンタのリセット
   FinishCount = 0 ' カウンタのリセット
   DelayCount = 0 ' カウンタのリセット
   SumPV = 0
   SumEffPV = 0
   SumEV = 0
   SumAC = 0
   ' ********** 変数リセット 終了 **********
End Sub

' 全体およびレベル2以下に属すタスク数・PV等を
' レベル3以下に属すタスク数・PV等を合計しシートに転記
Sub 合計値計算(sSh As String)

   ' ********** 変数の定義 開始 **********
   ' EVM値
   Dim PV As Double
   Dim EffPV As Double
   Dim EV As Double
   Dim AC As Double

   ' EVM値集計
   Dim SumPV As Double
   Dim SumEffPV As Double
   Dim SumEV As Double
   Dim SumAC As Double

   ' タスク数集計
   Dim TaskNum As Long
   Dim PlanTaskNum As Long
   Dim ActTaskNum As Long
   Dim DelTaskNum As Long

   ' タスク数集計
   Dim SumTaskNum As Long
   Dim SumPlanTaskNum As Long
   Dim SumActTaskNum As Long
   Dim SumDelTaskNum As Long

   ' 行番号
   Dim RowStart
   Dim RowStop

   ' シート
   Dim sh As Worksheet
   ' ********** 変数の定義 開始 **********


   ' ********** 初期設定 開始 **********
   ' 処理対象とする最終行
   RowLimit = 65536
   ' ********** 初期設定 終了 **********


   ' ********** 合算/転記 開始 **********
   ' オブジェクト型変数の代入
   Set sh = Worksheets(sSh)

   ' 合計を計算するための初期位置に移動
   sh.Cells(2, 2).Select
   Selection.End(xlDown).Select

   ' 最終行に至るまで処理を実行
   ' レベル2間にあるレベル3の値を合計する
   While RowStop < RowLimit
      ' カーソルのあるセルの行番号を取得
      RowStart = ActiveCell.Row
      ' 次のレベル2までジャンプ
      Selection.End(xlDown).Select
      ' カーソルのあるセルの行番号を取得
      RowStop = ActiveCell.Row

      ' レベル2にひもづくタスク数の合計
      TaskNum = WorksheetFunction.Sum(Range(sh.Cells(RowStart, 7), _
                                    sh.Cells(RowStop - 1, 7)))
      ' レベル2にひもづく計画タスク数の合計
      PlanTaskNum = WorksheetFunction.Sum(Range(sh.Cells(RowStart, 8), _
                                       sh.Cells(RowStop - 1, 8)))
      ' レベル2にひもづく実績タスク数の合計
      ActTaskNum = WorksheetFunction.Sum(Range(sh.Cells(RowStart, 9), _
                                       sh.Cells(RowStop - 1, 9)))
      ' レベル2にひもづく遅延タスク数の合計
      DelTaskNum = WorksheetFunction.Sum(Range(sh.Cells(RowStart, 10), _
                                       sh.Cells(RowStop - 1, 10)))

      ' レベル2の値を集計
      SumTaskNum = SumTaskNum + TaskNum
      SumPlanTaskNum = SumPlanTaskNum + PlanTaskNum
      SumActTaskNum = SumActTaskNum + ActTaskNum
      SumDelTaskNum = SumDelTaskNum + DelTaskNum

      ' レベル2以下に属すタスク数合計
      sh.Cells(RowStart, 7).Value = TaskNum
      ' レベル2以下に属す計画タスク数合計
      sh.Cells(RowStart, 8).Value = PlanTaskNum
      ' レベル2以下に属す実績タスク数合計
      sh.Cells(RowStart, 9).Value = ActTaskNum
      ' レベル2以下に属す遅延タスク数合計
      sh.Cells(RowStart, 10).Value = DelTaskNum


      ' レベル2にひもづくPVの合計
      PV = WorksheetFunction.Sum(Range(sh.Cells(RowStart + 1, 13), _
                                 sh.Cells(RowStop - 1, 13)))
      ' レベル2にひもづく実PVの合計
      EffPV = WorksheetFunction.Sum(Range(sh.Cells(RowStart + 1, 16), _
                                 sh.Cells(RowStop - 1, 16)))
      ' レベル2にひもづくEVの合計
      EV = WorksheetFunction.Sum(Range(sh.Cells(RowStart + 1, 14), _
                                 sh.Cells(RowStop - 1, 14)))
      ' レベル2にひもづくACの合計
      AC = WorksheetFunction.Sum(Range(sh.Cells(RowStart + 1, 15), _
                                 sh.Cells(RowStop - 1, 15)))

      ' レベル2の値を集計
      SumPV = SumPV + PV
      SumEffPV = SumEffPV + EffPV
      SumEV = SumEV + EV
      SumAC = SumAC + AC

      ' レベル2以下に属すPV合計
      sh.Cells(RowStart, 13).Value = PV
      ' レベル2以下に属す実PV合計
      sh.Cells(RowStart, 16).Value = EffPV
      ' レベル2以下に属すEV合計
      sh.Cells(RowStart, 14).Value = EV
      ' レベル2以下に属すAC合計
      sh.Cells(RowStart, 15).Value = AC
   Wend

   ' レベル1以下に属すタスク数合計
   sh.Cells(2, 7).Value = SumTaskNum
   ' レベル1以下に属す計画タスク数合計
   sh.Cells(2, 8).Value = SumPlanTaskNum
   ' レベル1以下に属す実績タスク数合計
   sh.Cells(2, 9).Value = SumActTaskNum
   ' レベル1以下に属す遅延タスク数合計
   sh.Cells(2, 10).Value = SumDelTaskNum

   ' レベル1以下に属すPV合計
   sh.Cells(2, 13).Value = SumPV
   ' レベル1以下に属す実PV合計
   sh.Cells(2, 16).Value = SumEffPV
   ' レベル1以下に属すEV合計
   sh.Cells(2, 14).Value = SumEV
   ' レベル1以下に属すAC合計
   sh.Cells(2, 15).Value = SumAC
   ' ********** 合算/転記 終了 **********


   ' ********** 変数リセット 開始 **********
   PV = 0
   EffPV = 0
   EV = 0
   AC = 0
   TaskNum = 0
   PlanTaskNum = 0
   ActTaskNum = 0
   DelTaskNum = 0
   SumPV = 0
   SumEffPV = 0
   SumEV = 0
   SumAC = 0
   SumTaskNum = 0
   SumPlanTaskNum = 0
   SumActTaskNum = 0
   SumDelTaskNum = 0
   ' ********** 変数リセット 終了 **********
End Sub

' 特定のシートの指定した列で値がある行数を数えて、それらの行の空欄に3行目の式をコピー
Sub 計算式をコピー(sSh As String)

   Dim RowStop
   Dim sh As Worksheet

   ' オブジェクト型変数の代入
   Set sh = Worksheets(sSh)

   ' 行数を数えるための初期位置に移動
   sh.Cells(2, 4).Select
   ' 最終行まで移動
   Selection.End(xlDown).Select
   ' カーソルのあるセルの行番号を取得
   RowStop = ActiveCell.Row

   ' 予定工数の数式をコピーし、各行の空欄にコピー
   Worksheets(sSh).Cells(2, 6).Copy
   Worksheets(sSh).Range(Cells(2, 6), Cells(RowStop, 6)).PasteSpecial

   ' SPI,CPIの数式をコピーし、各行の空欄にコピー
   Worksheets(sSh).Range(Cells(2, 11), Cells(2, 12)).Copy
   Worksheets(sSh).Range(Cells(2, 11), Cells(RowStop, 12)).PasteSpecial

   ' 変換係数の数式をコピーし、各行の空欄にコピー
   Worksheets(sSh).Cells(2, 17).Copy
   Worksheets(sSh).Range(Cells(2, 17), Cells(RowStop, 17)).PasteSpecial

End Sub
ホーム
inserted by FC2 system