Excel VBA - 使用 MS Project 创建列名称 headers

Question

我正在编写一个脚本，用 MS Project 文件中的数据填充 excel 传播sheet。我希望脚本能够识别 MS 项目列的标题名称，因为我有许多具有不同名称的自定义列（自定义数字字段填充有不同的名称）

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

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

尝试下面的代码，代码注释中的解释：

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

Answer 2

这是循环遍历活动任务 table 中的字段并打印出 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

请注意，可以在项目级别自定义字段以赋予不同的标题，或者可以在 table 级别自定义字段。此代码查找两个自定义项，如果均未找到，则使用字段名称。

Excel VBA - 使用 MS Project 创建列名称 headers

Excel VBA - create column names using MS Project headers

excel

vba

ms-project