Excel VBA - создавать имена столбцов, используя заголовки MS Project

Question

Я нахожусь в процессе написания сценария, который заполняет электронную таблицу Excel данными из файла MS Project. Я хотел бы, чтобы скрипт распознавал название заголовка столбцов 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

Попробуйте код ниже, объяснение внутри комментариев кода:

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