CODEWITHSUNDEEP
excelvbams-project
PootyToot
PootyToot

Reputation: 329

Excel VBA - create column names using MS Project headers

I'm in the middle of writing a script that populates an excel spreadsheet with data from an MS Project file. I would like the script to recognize the title name of the MS Project columns as I have a number of custom columns with different names (custom number fields are populated with different names)

The code below was my attempt, but i'm getting an error when it comes to writing the value of the task column title to the sheet, am I doing something wrong here?

Sub PopulateSheet()
Dim Proj             As MSProject.Application
Dim NewProj          As MSProject.Project
Dim t                As MSProject.Task        

Dim xl as workbook
Dim s as worksheet
Dim Newsheet as worksheet

Set Xl = ThisWorkbook
BookNam = Xl.Name
Set Newsheet = Xl.Worksheets.Add

'Code to find and open project files
Set Proj = New MSProject.Application
MsgBox ("Please Select MS Project File for Quality Checking")

'Select Project File
FileOpenType = Application.GetOpenFilename( _
               FileFilter:="MS Project Files (*.mpp), *.mpp", _
               Title:="Select MS Project file", _
               MultiSelect:=False)

'Detect if File is selected, if not then stop code
If FileOpenType = False Then
    MsgBox ("You Havent Selected a File")
    Exit Sub
End If

'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)       

Newsheet.Name = NewProjFileName
Set s = Newsheet

'Populate spreadsheet header row with column titles from MS Project
s.Range("A1").Value = t.Number1  ***<-- Error '91' - Object variable or With block variable not set***

End Sub

Upvotes: 0

Views: 1329

Answers (2)

Rachel Hettinger
Rachel Hettinger

Reputation: 8442

Here is generic code that loops through the fields in the active task table and prints out the field headings as displayed in the table.

Sub GetTaskTableHeaders()

    Dim t As Table
    Set t = ActiveProject.TaskTables(ActiveProject.CurrentTable)
    Dim f As TableField
    For Each f In t.TableFields
        If f.Field > 0 Then
            Dim header As String
            Dim custom As String
            custom = Application.CustomFieldGetName(f.Field)
            If Len(f.Title) > 0 Then
                header = f.Title
            ElseIf Len(custom) > 0 Then
                header = custom
            Else
                header = Application.FieldConstantToFieldName(f.Field)
            End If
            Debug.Print "Field " & f.Index, header
        End If
    Next f

End Sub

Note that fields can be customized at the project level to be given a different title, or they can be customized at the table level. This code looks for both customizations and if neither is found, the field name is used.

Upvotes: 1

Shai Rado
Shai Rado

Reputation: 33682

Try the code below, explanation inside the code's comments:

Option Explicit

Sub PopulateSheet()

Dim Proj                As MSProject.Application
Dim NewProj             As MSProject.Project
Dim PjTableField        As MSProject.TableField   ' New Object
Dim PjTaskTable         As MSProject.Table  ' New Object
Dim t                   As MSProject.task

Dim xl As Workbook
Dim s As Worksheet
Dim Newsheet As Worksheet
Dim BookName As String
Dim FileOpenType
Dim NewProjFilePath As String, NewProjFileName As String

Set xl = ThisWorkbook
BookName = xl.Name
Set Newsheet = xl.Worksheets.Add

'Code to find and open project files
Set Proj = New MSProject.Application
MsgBox ("Please Select MS Project File for Quality Checking")

'Select Project File
FileOpenType = Application.GetOpenFilename( _
               FileFilter:="MS Project Files (*.mpp), *.mpp", _
               Title:="Select MS Project file", _
               MultiSelect:=False)

'Detect if File is selected, if not then stop code
If FileOpenType = False Then
    MsgBox ("You Havent Selected a File")
    Exit Sub
End If

'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)

Newsheet.Name = NewProjFileName
Set s = Newsheet

' Open MS-Project File
Proj.FileOpen NewProjFilePath & NewProjFileName
Set NewProj = Proj.ActiveProject


' ===== New code Section =====

' set the Table object
Set PjTaskTable = NewProj.TaskTables(NewProj.CurrentTable)

' loop through all tablefields in table
For Each PjTableField In PjTaskTable.TableFields
    If PjTableField.Field = pjTaskNumber1 Then ' check if currect field numeric value equals the numeric value of "Number1"
        'Populate spreadsheet header row with column titles from MS Project
        s.Range("A1").Value = PjTableField.Title ' populate "A1" with the field's title and
    End If
Next PjTableField

End Sub

Upvotes: 0

Related Questions