Excel VBA - 使用 MS Project 标题创建列名

Question

我正在编写一个脚本，该脚本使用 MS Project 文件中的数据填充 Excel 电子表格。我希望脚本能够识别 MS Project 列的标题名称，因为我有许多具有不同名称的自定义列（自定义数字字段填充有不同的名称）

下面的代码是我的尝试，但是在将任务列标题的值写入工作表时出现错误，我在这里做错了吗？

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

Answer 1

这里是循环遍历活动任务表中的字段并打印出表中显示的字段标题的通用代码。

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

请注意，可以在项目级别自定义字段以赋予不同的标题，也可以在表格级别自定义字段。此代码查找这两个自定义项，如果都没有找到，则使用字段名称。

Answer 2

试试下面的代码，代码的 cmets 里面有解释：

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