Embedded Files
PM Forecasting Tables.xlsxVBA Professional!
Simplified_PM_Resource_Allocation_Table.xlsxMAC VERSION:
Option Explicit
Sub SummarizePMAllocation_MacSafe()
Dim ws As Worksheet, out As Worksheet
Dim lastRow As Long, r As Long, i As Long, pos As Variant
Dim pm As String, est As Double, allo As Double
Dim PMs() As String, EstSum() As Double, AlloSum() As Double, n As Long
Set ws = ThisWorkbook.Worksheets("Allocations")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Create/refresh output sheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("PM Allocation Summary").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set out = ThisWorkbook.Worksheets.Add(After:=ws)
out.Name = "PM Allocation Summary"
' Growable arrays (no ActiveX Dictionary)
ReDim PMs(1 To 1)
ReDim EstSum(1 To 1)
ReDim AlloSum(1 To 1)
n = 0
For r = 2 To lastRow
pm = CStr(ws.Cells(r, "C").Value)
If Len(pm) > 0 Then
est = CDbl(Val(ws.Cells(r, "E").Value))
allo = CDbl(Val(ws.Cells(r, "F").Value))
If n > 0 Then
pos = Application.Match(pm, Application.Index(PMs, Evaluate("ROW(1:" & n & ")")), 0)
Else
pos = CVErr(xlErrNA)
End If
If IsError(pos) Then
n = n + 1
ReDim Preserve PMs(1 To n)
ReDim Preserve EstSum(1 To n)
ReDim Preserve AlloSum(1 To n)
PMs(n) = pm
EstSum(n) = est
AlloSum(n) = allo
Else
EstSum(pos) = EstSum(pos) + est
AlloSum(pos) = AlloSum(pos) + allo
End If
End If
Next r
' Output
out.[A1:D1].Value = Array("Project Manager", "Total Estimated", "Total Allocated", "Over/Under (hrs)")
out.[E1].Value = "Meaning"
i = 2
For r = 1 To n
out.Cells(i, 1).Value = PMs(r)
out.Cells(i, 2).Value = EstSum(r)
out.Cells(i, 3).Value = AlloSum(r)
out.Cells(i, 4).Value = AlloSum(r) - EstSum(r)
out.Cells(i, 5).Value = IIf(out.Cells(i, 4).Value > 0, _
"Overallocated: risk of burnout/delays; reassign or add capacity.", _
IIf(out.Cells(i, 4).Value < 0, "Underallocated: idle capacity; shift work in.", _
"Balanced: monitor."))
i = i + 1
Next r
out.Columns.AutoFit
End Sub
Table summary:
Sub SummarizePMAllocation()
' Assumes data on sheet "Allocations" with headers in row 1:
' Columns: [A] Project, [B] Phase, [C] Project Manager, [D] Budget,
' [E] Estimated Hours, [F] Allocated Hours
Dim ws As Worksheet, out As Worksheet, r As Long, lastRow As Long
Dim dict As Object, k As Variant, pm As String
Dim est As Double, allo As Double
Set ws = ThisWorkbook.Worksheets("Allocations")
Set out = ThisWorkbook.Worksheets.Add(After:=ws)
out.Name = "PM Allocation Summary"
Set dict = CreateObject("Scripting.Dictionary")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For r = 2 To lastRow
pm = ws.Cells(r, "C").Value
est = ws.Cells(r, "E").Value
allo = ws.Cells(r, "F").Value
If Not dict.Exists(pm) Then dict(pm) = Array(0#, 0#)
dict(pm) = Array(dict(pm)(0) + est, dict(pm)(1) + allo)
Next r
' Headers
out.[A1:D1].Value = Array("Project Manager", "Total Estimated", "Total Allocated", "Over/Under (hrs)")
out.[E1].Value = "Meaning"
Dim i As Long: i = 2
For Each k In dict.Keys
est = dict(k)(0): allo = dict(k)(1)
out.Cells(i, 1).Value = k
out.Cells(i, 2).Value = est
out.Cells(i, 3).Value = allo
out.Cells(i, 4).Value = allo - est
out.Cells(i, 5).Value = IIf(allo - est > 0, _
"Overallocated: risk of burnout/delays; reassign or add capacity.", _
IIf(allo - est < 0, "Underallocated: idle capacity; shift work in.", _
"Balanced: monitor."))
i = i + 1
Next k
out.Columns.AutoFit
End Sub
Heat Map:
Sub BuildPMProjectHeatmap()
' Source sheet/columns assumed:
' "Allocations": [A] Project, [B] Phase, [C] Project Manager,
' [D] Budget, [E] Estimated Hours, [F] Allocated Hours
Dim ws As Worksheet, sh As Worksheet, pc As PivotCache, pt As PivotTable
Dim lastRow As Long, overCol As Long, src As Range
Set ws = Worksheets("Allocations")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Ensure helper column "OverUnder" = Allocated - Estimated
overCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
If ws.Cells(1, overCol - 1).Value <> "OverUnder" And ws.Cells(1, overCol).Value <> "OverUnder" Then
ws.Cells(1, overCol).Value = "OverUnder"
ws.Range(ws.Cells(2, overCol), ws.Cells(lastRow, overCol)).FormulaR1C1 = "=RC6-RC5"
Else
overCol = Application.Match("OverUnder", ws.Rows(1), 0)
ws.Range(ws.Cells(2, overCol), ws.Cells(lastRow, overCol)).FormulaR1C1 = "=RC6-RC5"
End If
Set src = ws.Range("A1").CurrentRegion
' Create/replace output sheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PM-Project Heatmap").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set sh = Worksheets.Add
sh.Name = "PM-Project Heatmap"
' Pivot: Rows=PM, Cols=Project, Values=Sum of OverUnder
Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=src)
Set pt = pc.CreatePivotTable(TableDestination:=sh.Range("A3"), TableName:="pmproj_pt")
With pt
.ManualUpdate = True
.PivotFields("Project Manager").Orientation = xlRowField
.PivotFields("Project").Orientation = xlColumnField
With .PivotFields("OverUnder")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Caption = "Over/Under (hrs)"
End With
.ColumnGrand = False
.RowGrand = False
.ManualUpdate = False
End With
' Title
sh.Range("A1").Value = "PM × Project Heatmap (Allocated - Estimated Hours)"
sh.Range("A1").Font.Bold = True
' Heatmap: 3-color scale centered at 0 (blue = under, white = balanced, red = over)
Dim dataBody As Range
On Error Resume Next
Set dataBody = pt.DataBodyRange
On Error GoTo 0
If Not dataBody Is Nothing Then
With dataBody.FormatConditions.AddColorScale(ColorScaleType:=3)
.ColorScaleCriteria(1).Type = xlConditionValueLowestValue ' min
.ColorScaleCriteria(2).Type = xlConditionValueNumber ' center = 0
.ColorScaleCriteria(2).Value = 0
.ColorScaleCriteria(3).Type = xlConditionValueHighestValue ' max
End With
End If
sh.Columns.AutoFit
End Sub
Page updated
Google Sites
Report abuse