How can I make a macro in Excel workbook tab to open MS Project and copy reference cells

问题

Situation: Our company has an Open Issues list we use for individual parts during trialing/launching a program. The program has its own Excel document, and each part has its own tab in that document for a running list of that specific part. It has recently been proposed that we track how long issues are open using MS Project. I can take the information from our Excel tab and manually copy it into Project to show what we want, and I can have Project automatically update linked sources if it is 1:1 Excel sheet to Project sheet, but we only need 1 Project sheet at a time, and they need to update based on the open tab of the workbook, so the reference changes based on what part we're looking at.

Goal: I am looking for macro code for either/both Excel and Project that can run based on a single click that will take the reference cells in Excel copy over to Project.

So the users will open Excel and go to the tab of the part they want a chart of in Project. They will then be able to click a button in that tab that 1) opens the formatted Project file 2) selects specific cells on that Excel tab to copy over to Project [for example, in Excel lines BE60:BI60 will copy over into line 1 of Project, BE67:BI67 to line 2, so on]. I can get the macro to open Project easily enough from Excel, but am struggling on where to even begin on copying the link source based on current tab.

The solved code I've went with is below:

    Sub UpdateProject()

    Dim projApp As MSProject.Application

    On Error Resume Next
    Set projApp = GetObject(, "MSProject.Application")
    If projApp Is Nothing Then
        Set projApp = New MSProject.Application
    End If
    projApp.Visible = True
    On Error GoTo 0

    projApp.FileOpenEx "C:\[File Location]\[File Name].mpp"

    Dim wst As Worksheet
    Set wst = ActiveSheet
    Dim rng As Range
    Set rng = wst.Range("D60")
    Dim lRow As Long
    lRow = rng.Row

    Do While lRow >= 60 And rng.Column = 4 And IsDate(wst.Cells(lRow, 7).Value)

        Dim taskName As String
        taskName = wst.Cells(lRow, 57) ' column BE
        If Len(taskName) > 0 Then
            ' find task in project schedule
            projApp.Find Field:="Name", Test:="equals", Value:=taskName
            Dim t As MSProject.Task
            If projApp.ActiveCell = taskName Then
                Set t = projApp.ActiveCell.Task

            Else    ' did not find the task, so add it
                Set t = projApp.ActiveProject.Tasks.Add(taskName)
            End If
            t.Start = wst.Cells(lRow, 59).Value         ' column BG
            t.Finish = wst.Cells(lRow, 60).Value        ' column BH
            t.ResourceNames = wst.Cells(lRow, 61).Value ' column BI
        End If

        ' find next trial
        Set rng = wst.UsedRange.Find(What:="Trial Date", After:=rng, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        lRow = rng.Row
    Loop

End Sub

回答1:

Here is code that opens the MS Project file from Excel and updates the schedule from the active tab in the Excel file.

The trick is to use the Find method of the Project Application object to find the task, then set a Task object variable to make updating the fields simple. Don't bother updating the Duration field as that will be calculated based on the Start and Finish.

Sub UpdateProject()

    Dim projApp As MSProject.Application

    On Error Resume Next
    Set projApp = GetObject(, "MSProject.Application")
    If projApp Is Nothing Then
        Set projApp = New MSProject.Application
    End If
    projApp.Visible = True
    On Error GoTo 0

    projApp.FileOpenEx "C:\[File Location]\[File Name].mpp"

    Dim wst As Worksheet
    Set wst = ActiveSheet
    Dim rng As Range
    Set rng = wst.Range("D60")
    Dim lRow As Long
    lRow = rng.Row

    Do While lRow >= 60 And rng.Column = 4 And IsDate(wst.Cells(lRow, 7).Value)

        Dim taskName As String
        taskName = wst.Cells(lRow, 57) ' column BE
        If Len(taskName) > 0 Then
            ' find task in project schedule
            projApp.Find Field:="Name", Test:="equals", Value:=taskName
            Dim t As MSProject.Task
            If projApp.ActiveCell = taskName Then
                Set t = projApp.ActiveCell.Task

            Else    ' did not find the task, so add it
                Set t = projApp.ActiveProject.Tasks.Add(taskName)
            End If
            t.Start = wst.Cells(lRow, 59).Value         ' column BG
            t.Finish = wst.Cells(lRow, 60).Value        ' column BH
            t.ResourceNames = wst.Cells(lRow, 61).Value ' column BI
        End If

        ' find next trial
        Set rng = wst.UsedRange.Find(What:="Trial Date", After:=rng, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        lRow = rng.Row
    Loop

End Sub

来源：https://stackoverflow.com/questions/60552888/how-can-i-make-a-macro-in-excel-workbook-tab-to-open-ms-project-and-copy-referen