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

• 26. april 2012 19:18

   

   
  

  0

  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.

  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

  
  
  • Besvar
  • Citer