Import Excel into Microsoft Project

问题

I would like to create an automated tool to import the excel for Microsoft Project file. I am trying to achieve this in VBA (please suggest me, If any other options there) and i researched some code for basic setup.

I found following link to setup the system and code to do this automation but still not sure below code is exact my findings or not.

Sources :

https://www.linkedin.com/pulse/how-automate-ms-project-from-excel-app-malcolm-farrelle?trk=portfolio_article-card_title

Automate creating n Microsoft Project files from an excel file with n rows

I would like write the update script using Mapping field and create/append as new projects.

Update

With help of below answer, I have rewritten the code to import the multiple files and saved it as *.mpp file.

but the problem is mpp file is opening and it should happen in the backend user should not view naything.

Code:

Private Sub ImportButton_Click()
    On Error GoTo Exception
        
    Dim InputFolderPath As String, DefaultInputFolderPath As String, DefaultOutputFolderPath  As String
    Dim fileExplorer As FileDialog
    
    InputFolderPath = ""
    DefaultInputFolderPath = "D:\Sample Projects\MPP Import\Input\"
    DefaultOutputFolderPath = "D:\Sample Projects\MPP Import\Output\"
    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
    
     'To allow or disable to multi select
    fileExplorer.AllowMultiSelect = False
    If fileExplorer.Show = -1 Then 'Any folder is selected
        InputFolderPath = fileExplorer.SelectedItems.Item(1) & "\"
    Else
        InputFolderPath = DefaultInputFolderPath
    End If
       
    Call CreateProjectFromExcelFile(InputFolderPath, DefaultOutputFolderPath)
    
Exception:
    Select Case err.Number   ' Evaluate error number.
        Case 0
            Exit Sub
        Case Else
            MsgBox "UNKNOWN ERROR  - Error# " & err.Number & " : " & err.Description
    End Select
    Exit Sub
ExitCode:
    Exit Sub
End Sub

Public Sub CreateProjectFromExcelFile(InputFolderPath As String, DefaultOutputFolderPath As String)

    Dim myFile As String, myExtension As String, oFullFilename As String, oFilename As String
  

    ' get access to Project application object
    Dim appMSP As MSProject.Application
    On Error Resume Next
    ' see if the application is already open
    Set appMSP = GetObject(, "MSProject.Application")
    If err.Number <> 0 Then
        ' wasn't open, so open it
        Set appMSP = CreateObject("MSProject.Application")
    End If
    ' return to whatever error handling you had
    On Error GoTo 0
    
    appMSP.Visible = False
      
    MapEdit Name:="ImportMap", Create:=True, OverwriteExisting:=True, DataCategory:=0, CategoryEnabled:=True, TableName:="Data", FieldName:="Name", ExternalFieldName:="Task_Name", ExportFilter:="All Tasks", ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
    MapEdit Name:="ImportMap", DataCategory:=0, FieldName:="Duration", ExternalFieldName:="Duration"
    MapEdit Name:="ImportMap", DataCategory:=0, FieldName:="Start", ExternalFieldName:="Start_Date"
    MapEdit Name:="ImportMap", DataCategory:=0, FieldName:="Finish", ExternalFieldName:="End_Date"
    MapEdit Name:="ImportMap", DataCategory:=0, FieldName:="Resource Names", ExternalFieldName:="Resource_Name"
    MapEdit Name:="ImportMap", DataCategory:=0, FieldName:="Notes", ExternalFieldName:="Remarks"
    ' open the Excel file to import
    Dim strFilepath As String
    'Target File Extension (must include wildcard "*")
    myExtension = "*.xlsx"

    'Target Path with Ending Extention
    myFile = Dir(InputFolderPath & myExtension)
            
            'Loop through each Excel file in folder
    While myFile <> ""
        If (myFile = "") Then
            MsgBox ("No files avaalable!")
            GoTo ExitCode
        End If
        
        'This example will print the file name to the immediate window
         strFilepath = InputFolderPath & myFile
         
         oFullFilename = Right(strFilepath, Len(strFilepath) - InStrRev(strFilepath, "\"))
         oFilename = Left(oFullFilename, (InStr(oFullFilename, ".") - 1))
         
         appMSP.Visible = False
         
         appMSP.FileOpenEx Name:=strFilepath, ReadOnly:=False, Merge:=1, FormatID:="MSProject.ACE", Map:="ImportMap"
         appMSP.FileSaveAs Name:=DefaultOutputFolderPath & oFilename & ".mpp"
        'Set the fileName to the next file
         myFile = Dir
    Wend
    appMSP.FileCloseAllEx pjDoNotSave
    Set appMSP = Nothing
    MsgBox ("Imported Successfully...")
ExitCode:
    Exit Sub
End Sub

回答1:

I would like to create an automated tool to import the excel for Microsoft Project file.

Automating making a new Microsoft Project file from an Excel file is very easy—it's a single command: FileOpenEx.

Here is how you can do it from Excel:

Sub CreateProjectFromExcelFile()

    ' get access to Project application object
    Dim appMSP As MSProject.Application
    On Error Resume Next
    ' see if the application is already open
    Set appMSP = GetObject(, "MSProject.Application")
    If Err.Number <> 0 Then
        ' wasn't open, so open it
        Set appMSP = CreateObject("MSProject.Application")
    End If
    ' return to whatever error handling you had
    On Error GoTo 0
    
    appMSP.Visible = True
    
    ' open the Excel file to import
    appMSP.FileOpenEx Name:="C:\<your path here>\SampleNewProjectForImport.xlsx" _
        , Map:="<your map name here>"
    
    appMSP.FileSaveAs Name:="MyProject.mpp"
    
End Sub

Update the paths/names in the FileOpenEx line with your names, add error handling and other code as you want, and add a reference to the Project Object library.

Note: If you don't know how importing works in MS Project, see Import Excel data into Project for an explanation of how the process works.

Note 2: The same command is used to append to or update an existing schedule.

来源：https://stackoverflow.com/questions/62467266/import-excel-into-microsoft-project