Show only certain Tasks and Columns in a MPP file.. AND Help with VBA

[kpierce]

Hello:
I need to be able to provide several project schedules on a weekly basis. I only show tasks that are displayed on the screen in the current view. For example, I might want to collapse some tasks and only show the roll up..

I have found the following code that will take what is on the screen in my current MPP file and export it to XLS. This is a great start, however I want to have this in an MPP file, not an XLS.
I am using MS Project 2007

So I have two questions:

1. Can I save a current MPP file and only include the tasks AND columns that are currently displayed on the screen. So if someone opens it, they CAN'T view hidden columns, or tasks.

2. If not, can someone PLEASE, PLEASE help me modify this VBA code so it will 'export' this information into another MPP file instead of XLS?

I really appreciate any help and support that can be provided.

Thanks

Option Explicit

'store information about what is on each row
Type RowType
    TaskType As String
    OutlineNumber As String
    OutlineLevel As Integer
End Type
  
Sub Export2ExcelComp()
    Dim Rows As Integer, Columns As Integer, Item() As String
    Dim RowTypes() As RowType
    Dim Row As Integer, Column As Integer, Count As Integer
    Dim NameColumn As Integer, Color As Long, Indent As Integer
    Dim StartColumn As Integer, FinishColumn As Integer, CompColumn As Integer
    Dim Text As String, TaskType As String, ProjectName As String
    Dim Filename As Variant, Task As Task
    Dim NameColumnTitle As String, FinishColumnTitle As String, CompColumnTitle As String
    Dim objExcel As Object, objBook As Object
    
    On Error GoTo Error_Handler
    
    '==========================
    'Project part of macro
    '==========================
    'get project name from title
    ProjectName = ActiveProject.ProjectSummaryTask.Name
    'get name column title
    SelectTaskColumn Column:="Name"
    NameColumnTitle = ActiveCell.FieldName
    SelectTaskColumn Column:="Finish"
    FinishColumnTitle = ActiveCell.FieldName
    SelectTaskColumn Column:="% Complete"
    CompColumnTitle = ActiveCell.FieldName
    'select entire area
    SelectSheet
    'perform extraction
    Rows = ActiveSelection.Tasks.Count + 1
    Columns = ActiveSelection.FieldIDList.Count
    ReDim Item(Rows, Columns)
    ReDim RowTypes(Rows)
    'grab the header row (not available in selection)
    Row = 1
    For Column = 1 To Columns
        Text = Application.CustomFieldGetName(ActiveSelection.FieldIDList(Column))
        If Text = "" Then Text = ActiveSelection.FieldNameList(Column)
        Item(Row, Column) = Text
    Next
    'grab the row description
    For Each Task In ActiveSelection.Tasks
        Row = Row + 1
        TaskType = "N"
        If Not (Task Is Nothing) Then 'used to detect blank lines
            If Task.Summary Then TaskType = "S"
            If Task.Milestone Then TaskType = "M"
            RowTypes(Row).TaskType = TaskType
            RowTypes(Row).OutlineLevel = Task.OutlineLevel
            RowTypes(Row).OutlineNumber = Task.OutlineNumber
            ' grab the selection details
            For Column = 1 To Columns
                Item(Row, Column) = Task.GetField(ActiveSelection.FieldIDList(Column))
            Next
        End If
    Next
    '==========================
    'Excel part of macro
    '==========================
    'set up a new worksheet
    Set objExcel = CreateObject("Excel.Application")
    With objExcel
        .Application.Visible = True
        .Workbooks.Add
    End With
    Set objBook = objExcel.ActiveWorkbook
    'write the column headers
    Row = 1
    For Column = 1 To Columns
        'set the column header format
        objExcel.cells(Row, Column) = Item(Row, Column)
        objExcel.cells(Row, Column).Font.Bold = True
        objExcel.cells(Row, Column).Font.Underline = False
        objExcel.cells(Row, Column).Font.Color = RGB(255, 255, 255)
        objExcel.cells(Row, Column).Interior.Color = RGB(0, 0, 255)
        'get column numbers and size task name field
        If Item(Row, Column) = NameColumnTitle Then
            NameColumn = Column
            objExcel.Columns(Column).columnwidth = 50
        ElseIf Item(Row, Column) = FinishColumnTitle Then
             FinishColumn = Column
        ElseIf Item(Row, Column) = CompColumnTitle Then
             CompColumn = Column
        End If
    Next
    'write the selection details
    For Row = 2 To Rows
        TaskType = RowTypes(Row).TaskType
        'format the row according to task type
        objExcel.Rows(Row).Font.Bold = (TaskType = "S")
        Color = RGB(0, 0, 0)
        If TaskType = "S" Then Color = RGB(0, 0, 0)
        If TaskType = "M" Then Color = RGB(0, 0, 0)
        objExcel.Rows(Row).Font.Color = Color
        'align vertical to top
        objExcel.Rows(Row).VerticalAlignment = -4160
        objExcel.Rows(Row).WrapText = True
        For Column = 1 To Columns
        'if this is the name column, we need to indent it and add the outline number
            If Column = NameColumn Then
                Text = ""
                For Count = 1 To RowTypes(Row).OutlineLevel
                    Indent = Indent + 1
                Next
                objExcel.cells(Row, Column) = Text + Item(Row, Column)
                objExcel.cells(Row, Column).IndentLevel = Indent
            ElseIf Column = FinishColumn Then
                objExcel.cells(Row, Column).FormatConditions.Delete
                objExcel.cells(Row, Column).FormatConditions.Add Type:=2, Formula1:= _
                    "=IF(R" & Row & "C" & CompColumn & "=0,IF(R" & Row & "C" & Column & "<NOW(),1,0),0)"
                objExcel.cells(Row, Column).FormatConditions(1).Font.ColorIndex = 2
                objExcel.cells(Row, Column).FormatConditions(1).Interior.ColorIndex = 3
                objExcel.cells(Row, Column).FormatConditions.Add Type:=2, Formula1:= _
                    "=IF(R" & Row & "C" & CompColumn & "=0,IF(R" & Row & "C" & Column & "<NOW()+2,1,0),0)"
                objExcel.cells(Row, Column).FormatConditions(2).Interior.ColorIndex = 6
                objExcel.cells(Row, Column) = Item(Row, Column)
            Else
                objExcel.cells(Row, Column) = Item(Row, Column)
            End If
        Next
        Indent = 0
    Next
    'make the columns fit - within some limits
    objExcel.Columns.AutoFit
    For Column = 1 To Columns
        Count = objExcel.Columns(Column).columnwidth
        Text = Item(1, Column)
        If Column <> NameColumn And Count > 12 Then
            objExcel.Columns(Column).columnwidth = 16
        End If
        If Column = NameColumn Then
            objExcel.Columns(Column).columnwidth = 80
        End If
    Next
    'delete the indicators column
    For Column = 1 To Columns
        Text = Item(1, Column)
        If Text = "Indicators" Then
            objExcel.Columns(Column).Delete
            Exit For
        End If
    Next
    'turn on autofilter
    objExcel.Worksheets(1).Range("A1").AutoFilter
    'objExcel.Worksheets(1).Range("A1").AutoFilter Field:=7, Criteria1:="<100%", Operator:=1
    'set up page
    With objExcel.Worksheets(1).PageSetup
        .PrintTitleRows = "$1:$1"
        .CenterHeader = ProjectName
        .leftfooter = "&D &T"
        .CenterFooter = ""
        .rightfooter = "&P of &N"
        'set orientation to landscape
        .Orientation = 2
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 50
        .PrintGridlines = True
    End With
    'bring up the dialog to ask for a filename
    Filename = objExcel.Application.GetSaveAsFilename( _
        FileFilter:="Excel Spreadsheets (*.xls), *.xls", _
        InitialFilename:="ProjectExtract.xls", _
        Title:="Save Project Extract to Excel as")
    'save the file as a shared work with tracking
    objExcel.ActiveWorkbook.KeepChangeHistory = True
    If Filename <> False Then objBook.SaveAs Filename:=Filename
    Set objExcel = Nothing
    Set objBook = Nothing
Exit Sub
    
Error_Handler:
    MsgBox Error
    Set objExcel = Nothing
    Set objBook = Nothing
End Sub

 

[ierland]

Actually I did not look at your code at all. I wonder what you are really up to. I get the feeling that you want others only to have a look at your view and nothing more. Hiding would, as far as I know, not help a bit as everyone would be able to add columns again.
I would make a separate view with all the columns you want to show and a few others as well. This would include Overview Level, Constraint Type and Constraint date, Deadline Date [if used by you, something I would highly recommend], perhaps Task calendars etc.
If you use anything special, e.g. Filters, Groups, Custom fields [as far needed in the new file],Views with specific Bar Styles, make sure that you copy these with the Organizer to a new Project File. Set also the correct Start Date for the Project. Also arrange all columns in the new file exactly as in the special view in your original. [This can easily done with the Organizer as well, just by copying the table] Then select the columns [NOT the whole view] in the original file, copy and paste to the new one. Hide some additional columns [such as Overview Level] and save the new file. Now only additional Custom Fields can not be retrieved by someone using the new file [and perhaps also no baselines if not copied] Remember that if you filter certain rows away, containing links, that the new schedule may contain new constraints as you have Start dates included.
This looks perhaps rather complicated. However, if it would always refer to the same project, just make a template in which to paste. You could make a macro for that. However, in my view preparing the template and the simple copy paste may be much faster.
If you only would like to show the information to others, why not just print as a pdf-file from your special view?
Once more, realize that all fields in a given file can be made visible, no matter what you want to hide. If you only want to hide certain rows then still a full copy paste would not help you.
Success.


Why an easy solution if you can make it complicated?
Greetings from the Netherlands

 

[ierland]

Was my advise of any help?

Why an easy solution if you can make it complicated?
Greetings from the Netherlands