MS Project doesn't seem to honour row heights when printing.
BUT there is one simple hack:
Change the font size of the Task Name column to something different to the other columns.
Right-click the Task Name column header.
Untick "Wrap Text".
Tick "Wrap Text".
Now when printing, it'll honour the row heights.
MS Project Macros http://masamiki.com/project/macros.htm
' A little Macro which fans out predecessors, successors or both depending on the user input
' This macro works best if assigned to a button on your toolbar
' Uses Flag5 to store information - please be sure that this field is not currently in use
' Note: Does not work with Inserted/Consolidated projects as it does not handle external tasks
' Jack Dahlgren, Jan 11, 2001
' Do not redistribute without Author's Permission
' No guarantee of performance or suitability for any purpose
' Use only on files which have been backed up
' RELEASE HISTORY
' Version 1.2, Jan 11, 2001 - Added ability to show only driving/driven
' activities (FreeSlack = 0)
' Version 1.1, Jan 05, 2001 - Added ability to show critical items only,
' simplified ClearFlags
' Version 1.0, June 19, 2000 - Original version
' To Do: enable multiple traces by setting ClearFlags
' Work out trace through external tasks
Option Explicit
Dim Forward As Boolean
Dim SelectedID As Integer
Dim jString As String
Dim IsSum As Boolean
Dim IsCrit As Boolean
Dim IsDrive As Boolean
Dim jTask As Task
'This is the master macro
Sub Trace()
If ActiveSelection = 0 Then
MsgBox "You must have just one task selected for this macro to work"
Exit Sub
End If
If ActiveSelection.Tasks.Count <> 1 Then
MsgBox "You must have just one task selected for this macro to work"
Exit Sub
End If
'This sets flag used later for tracing paths.
jString = InputBox(("Please Enter Fan Type" & Chr(13) & Chr(13) & "P (Predecessors)" & Chr(13) & "S (Successors)" & Chr(13) & "A (All)"), "Fan-out Dependencies")
jString = UCase(Left(jString, 1))
If jString = "" Then
Exit Sub
End If
ClearFlags
IsCrit = False
For Each jTask In ActiveSelection.Tasks
If jTask.Summary = True Then
MsgBox "You have selected a summary task. Select a taks or milestone and try again"
Exit Sub
End If
If jTask.Critical = True Then
If MsgBox("Do you want to display only Critical Tasks?", 260, "Display Critical Tasks Only?") = vbYes Then
IsCrit = True
End If
End If
Next jTask
'This sets the flag for 0 free float (driving) tasks
IsDrive = False
For Each jTask In ActiveSelection.Tasks
If IsCrit = False Then
If MsgBox("Do you want to display only Driving Tasks?", 260, "Display Driving Tasks Only?") = vbYes Then
IsDrive = True
End If
End If
Next jTask
Select Case jString
Case "P"
TracePredecessors
Case "S"
TraceSuccessors
Case Else
TraceAll
End Select
FilterMe
If SelectedID > 0 Then Find Field:="ID", Test:="equals", Value:=SelectedID, Next:=True
End Sub
' Set all tasks Flag5 to false
Private Sub ClearFlags()
Dim jTask As Task
For Each jTask In ActiveProject.Tasks
If Not (jTask Is Nothing) Then
If jTask.Flag5 = True Then jTask.Flag5 = False
End If
Next jTask
End Sub
' Traces Only Successor Tasks - forward equal to true
Private Sub TraceSuccessors()
SelectedID = 0
Forward = True
MarkItem
End Sub
' Traces Only Predecessor Tasks - forward equal to false
Private Sub TracePredecessors()
SelectedID = 0
Forward = False
MarkItem
End Sub
' Traces All Tasks - one pass for successors, then one for predecessors
Private Sub TraceAll()
SelectedID = 0
Forward = True ' mark successors
MarkItem
Forward = False ' mark predecessors
MarkItem
End Sub
' Marks all tasks feeding by selected task(s)
Private Sub MarkItem()
Dim jTask As Task, jjTask As Task
For Each jTask In ActiveSelection.Tasks
If Not (jTask Is Nothing) Then
SelectedID = jTask.ID
If Not (jjTask Is Nothing) Then
If Not Forward Then
Fan jjTask
Else
jjTask.Flag5 = True
End If
If Not (jjTask Is Nothing) Then
If Forward Then
Fan jjTask
Else
jjTask.Flag5 = True
End If
End If
Else
Fan jTask
End If
End If
Next jTask
End Sub
' Walks through all predecessors or successors to a task and marks their flag5 as true
Private Sub Fan(jTask As Task)
Dim jjTask As Task
jTask.Flag5 = True
If Forward Then
For Each jjTask In jTask.SuccessorTasks
If jjTask.Flag5 <> True Then
If IsCrit And Not IsDrive Then
If jjTask.Critical = True Then
Fan jjTask
End If
ElseIf IsDrive = True Then
If jjTask.FreeSlack < 100 Then
Fan jjTask
End If
Else
Fan jjTask
End If
End If
Next jjTask
Else
For Each jjTask In jTask.PredecessorTasks
If jjTask.Flag5 <> True Then
If IsCrit And Not IsDrive Then
If jjTask.Critical = True Then
Fan jjTask
End If
ElseIf IsDrive = True Then
If jjTask.FreeSlack < 100 Then
Fan jjTask
End If
Else
Fan jjTask
End If
End If
Next jjTask
End If
End Sub
' Filter with or without summary tasks
Private Sub FilterMe()
If MsgBox("Do you want to display Summary Tasks?", vbYesNo, "Display Summary Tasks?") = vbYes Then
IsSum = True
Else: IsSum = False
End If
OutlineShowAllTasks
FilterEdit Name:="_Trace", TaskFilter:=True, _
Create:=True, _
OverwriteExisting:=True, _
FieldName:="Flag5", _
Test:="Equals", _
Value:="Yes", _
ShowInMenu:=False, _
ShowSummaryTasks:=IsSum
FilterApply Name:="_Trace"
End Sub
Sub CreateGroupingsOnIndents()
Dim cell As Range
If (Selection.Rows.Count = 1) And (Selection.Columns.Count = 1) Then
MsgBox ("Select the cells you wish to group by indent.")
Exit Sub
End If
For Each cell In Selection
If cell.IndentLevel <> 0 Then
cell.EntireRow.OutlineLevel = cell.IndentLevel
Else
cell.EntireRow.ClearOutline
End If
Next
End Sub
'http://www.mrexcel.com/forum/excel-questions/520950-visual-basic-applications-group-rows-wbs-ms-project.html
Alternate grouping
Sub CreateGroupingsOnIndents()
If ActiveWorkbook.MultiUserEditing Then
MsgBox ("This can only be done in exclusive mode (Review > Share Workbook)")
Exit Sub
End If
Dim cell As Range
'If (Selection.Rows.Count = 1) And (Selection.Columns.Count = 1) Then
' MsgBox ("Select the cells you wish to group by indent, excluding the first item.")
' Exit Sub
'End If
For Each cell In Selection
cell.EntireRow.OutlineLevel = cell.IndentLevel + 1
Next
End Sub
Groupings based on spaces (Project 2010)
Sub CreateGroupingsOnIndents()
If ActiveWorkbook.MultiUserEditing Then
MsgBox ("This can only be done in exclusive mode (Review > Share Workbook)")
Exit Sub
End If
Dim cell As Range
'If (Selection.Rows.Count = 1) And (Selection.Columns.Count = 1) Then
' MsgBox ("Select the cells you wish to group by indent, excluding the first item.")
' Exit Sub
'End If
For Each cell In Selection
Dim ttOrig As String
Dim ttNew As String
ttOrig = cell.Text
ttNew = LTrim(ttOrig)
cell.EntireRow.OutlineLevel = (Len(ttOrig) - Len(ttNew)) / 3 + 1
Next
End Sub
Sub NumberWbs()
Dim ind(1 To 10)
Dim EndRow As Range
Dim StartRow As Integer
Dim LastRow As Integer
Dim ColWithDesc As Integer
Dim colWithNum As Integer
ColWithDesc = 2
colWithNum = 1
StartRow = 1
LastRow = Cells(Rows.Count, ColWithDesc).End(xlUp).Row
Cells(LastRow, ColWithDesc).Select
Set EndRow = Application.InputBox(prompt:="select last row", _
Default:=Cells(LastRow, ColWithDesc).Offset(-12, 0).Address, Type:=8)
LastRow = EndRow.Row
For i = StartRow To LastRow
Cells(i, ColWithDesc).Select
Temp1 = Cells(i, ColWithDesc).IndentLevel + 1
If i = StartRow Then
ind(1) = 1
Else
Temp2 = Cells(i - 1, ColWithDesc).IndentLevel + 1
If Temp1 = Temp2 Then
ind(Temp1) = ind(Temp1) + 1
End If
If Temp1 > Temp2 Then
ind(Temp1) = 1
End If
If Temp1 < Temp2 Then
ind(Temp1) = ind(Temp1) + 1
For Temp3 = Temp1 + 1 To 10
ind(Temp3) = 0
Next Temp3
End If
End If
tempString = ""
tempstring2 = ""
For Temp3 = 1 To Temp1
tempString = tempString & ind(Temp3)
If Temp3 < 5 Then tempstring2 = tempstring2 & ind(Temp3)
If Temp3 < Temp1 Then
tempString = tempString & "."
If Temp3 < 4 Then tempstring2 = tempstring2 & "."
End If
Next Temp3
Cells(i, colWithNum) = tempString
'Cells(i, 2) = tempstring2
Next i
End Sub
'http://www.mrexcel.com/forum/excel-questions/520950-visual-basic-applications-group-rows-wbs-ms-project.html
Sub DecimalToIndent()
Dim Rng1 As Range 'numbers
Dim rng2 As Range 'descriptions
Dim NumCol As Long
Dim DescCol As Long
Dim TopRow As Long
Dim BotRow As Long
Dim AdStr As String
Dim i As Long
Dim j As Long
Dim k As Long
Set Rng1 = Application.InputBox(prompt:="select the numbers to use as a basis for indentation", Type:=8)
Set rng2 = Application.InputBox(prompt:="select the descriptions to be indented", Type:=8)
AdStr = CStr(Rng1.Address)
AdStr = Left(AdStr, Application.WorksheetFunction.Find(":", AdStr, 1) - 1)
TopRow = Range(AdStr).Row
NumCol = Range(AdStr).Column
AdStr = CStr(rng2.Address)
AdStr = Right(AdStr, Len(AdStr) - Application.WorksheetFunction.Find(":", AdStr, 1))
BotRow = Range(AdStr).Row
DescCol = Range(AdStr).Column
For i = TopRow To BotRow
k = 0
For j = 1 To Len(Cells(i, NumCol))
If Mid(Cells(i, NumCol), j, 1) = "." Then k = k + 1
Next j
Cells(i, DescCol).IndentLevel = k
Next i
End Sub
Sub IndentBasedOnPeriods()
'Indent Task Name column based upon the count of periods in the WBS field
Dim i As Long
For i = 1 To Range("setWBSCount").Count
'Indent each cell by the number of periods found in the WBS
If Range("AD2").Offset(i, 0).Value > 0 Then
Range("E2").Offset(i).IndentLevel = Range("AD2").Offset(i, 0).Value * 2
End If
Next i
End Sub
'http://www.mrexcel.com/forum/excel-questions/520950-visual-basic-applications-group-rows-wbs-ms-project.html
Sub IndentBasedOnWBSLevel()
'If the wbs level (1 ... N) is in col A
Dim cell As Range
Rows.ClearOutline
For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
cell.EntireRow.OutlineLevel = cell.Value
Next cell
End Sub
See NumberWBS in Excel: Indent macros