I have a massive current 3000 line program in ms project.. It will expand as we expect upwards of 1000 projects within.
We are required to weekly print out the full project (I don't know why, other than told to..)
So to have some fun I decided to create a macro to set the columns in specific order and width, then go back and open cells according to text in either Task or Notes.
Attached works to a point. It does not take into consideration of the tabbed tasks for inserted projects. Does anyone know how to calculate tab in task column for sizing?
Solutions welcome... BTW I know this could be cleaner have not coded at this level for years.
Thanks PD.
Sub clearslate()
' Macro clearslate for paper report formating
' Macro Recorded Jan 10 '12 by dw1671.
' section set to known first column
SelectColumn Column:=1
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Text27", Title:="", Width:=8, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
' puts in columns wanted in final view
' starts by asking how many columns exist beyond new column just entered
' now hides all other visible column then reinserts to known position and width
Dim strInput
strInput = InputBox("Please count number of columns to right of new status lights column")
SelectSheet
SelectColumn Column:=3, Additional:=strInput - 1
ColumnDelete
SelectSheet
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Successors", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Predecessors", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Finish", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Start", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Notes", Title:="Status Comments - UPDATE if RED Status Light", Width:=67, Align:=0, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Name", Title:="Task Name", Width:=56, Align:=0, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="% Complete", Title:="", Width:=8, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Text27", Title:="", Width:=7, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
' deletes starting point column entered at start
SelectColumn Column:=10
ColumnDelete
'opens all projects and tasks in project
OutlineShowTasks expandinsertedprojects:=True
'sets row-height to text in cell
'ISSUE at this point where inserted projects have tasks tabbed over.
'Tab is not figured into calculation for row height
SelectAll
romax = ActiveSelection.Tasks.Count
notescolwid = 67
namecolwid = 56
'sets counter to continue looping till all expanded rows checked
For Ctr = 1 To romax
SelectRow Row:=Ctr, rowrelative:=False
Set thisproj = ActiveSelection.Tasks(1)
If Not thisproj Is Nothing Then
RH = 1
RNotesLen = Len(thisproj.Notes)
RNameLen = Len(thisproj.Name)
'this portion checks to keep from opening more rows than text as text concantenates and shows ...
If RNotesLen > 255 Then RNotesLen = 255
RH1 = Round(RNotesLen / notescolwid)
If RH1 > 3 And notescolwid > 51 Then RH1 = 3
If RNameLen > 255 Then RNameLen = 255
RH2 = Round(RNameLen / namecolwid)
If RH2 > 3 And namecolwid > 51 Then RH2 = 3
' now code sets row height for each row dependent upon whether the Name or the Note has more verbiage
If RNotesLen Mod notescolwid > 0 Then RH1 = Round(RH1)
If RNameLen Mod namecolwid > 0 Then RH2 = Round(RH2)
RH = RH1
If RH1 > RH2 Then RH = RH1
If RH2 > RH Then RH = RH2
' next is clean up incase columns are narrow as Project row height max is 20
If RH > 20 Then RH = 20
If RH > 0 Then SetRowHeight Unit:=RH
End If
Next Ctr
End Sub
We are required to weekly print out the full project (I don't know why, other than told to..)
So to have some fun I decided to create a macro to set the columns in specific order and width, then go back and open cells according to text in either Task or Notes.
Attached works to a point. It does not take into consideration of the tabbed tasks for inserted projects. Does anyone know how to calculate tab in task column for sizing?
Solutions welcome... BTW I know this could be cleaner have not coded at this level for years.
Thanks PD.
Sub clearslate()
' Macro clearslate for paper report formating
' Macro Recorded Jan 10 '12 by dw1671.
' section set to known first column
SelectColumn Column:=1
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Text27", Title:="", Width:=8, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
' puts in columns wanted in final view
' starts by asking how many columns exist beyond new column just entered
' now hides all other visible column then reinserts to known position and width
Dim strInput
strInput = InputBox("Please count number of columns to right of new status lights column")
SelectSheet
SelectColumn Column:=3, Additional:=strInput - 1
ColumnDelete
SelectSheet
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Successors", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Predecessors", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Finish", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Start", Title:="", Width:=12, Align:=2, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Notes", Title:="Status Comments - UPDATE if RED Status Light", Width:=67, Align:=0, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Name", Title:="Task Name", Width:=56, Align:=0, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="% Complete", Title:="", Width:=8, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
SelectColumn Column:=2
TableEdit Name:="&Entry", TaskTable:=True, NewName:="", FieldName:="", NewFieldName:="Text27", Title:="", Width:=7, Align:=1, ShowInMenu:=True, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, ColumnPosition:=0, AlignTitle:=1
TableApply Name:="&Entry"
' deletes starting point column entered at start
SelectColumn Column:=10
ColumnDelete
'opens all projects and tasks in project
OutlineShowTasks expandinsertedprojects:=True
'sets row-height to text in cell
'ISSUE at this point where inserted projects have tasks tabbed over.
'Tab is not figured into calculation for row height
SelectAll
romax = ActiveSelection.Tasks.Count
notescolwid = 67
namecolwid = 56
'sets counter to continue looping till all expanded rows checked
For Ctr = 1 To romax
SelectRow Row:=Ctr, rowrelative:=False
Set thisproj = ActiveSelection.Tasks(1)
If Not thisproj Is Nothing Then
RH = 1
RNotesLen = Len(thisproj.Notes)
RNameLen = Len(thisproj.Name)
'this portion checks to keep from opening more rows than text as text concantenates and shows ...
If RNotesLen > 255 Then RNotesLen = 255
RH1 = Round(RNotesLen / notescolwid)
If RH1 > 3 And notescolwid > 51 Then RH1 = 3
If RNameLen > 255 Then RNameLen = 255
RH2 = Round(RNameLen / namecolwid)
If RH2 > 3 And namecolwid > 51 Then RH2 = 3
' now code sets row height for each row dependent upon whether the Name or the Note has more verbiage
If RNotesLen Mod notescolwid > 0 Then RH1 = Round(RH1)
If RNameLen Mod namecolwid > 0 Then RH2 = Round(RH2)
RH = RH1
If RH1 > RH2 Then RH = RH1
If RH2 > RH Then RH = RH2
' next is clean up incase columns are narrow as Project row height max is 20
If RH > 20 Then RH = 20
If RH > 0 Then SetRowHeight Unit:=RH
End If
Next Ctr
End Sub