时间戳

首页 > 解决方案 > 如何在 Excel 工作簿选项卡中创建宏以打开 MS Project 并复制参考单元格

excel - 如何在 Excel 工作簿选项卡中创建宏以打开 MS Project 并复制参考单元格

问题描述

情况：我们公司有一个未解决的问题列表，我们在试用/启动程序期间用于各个部分。该程序有自己的 Excel 文档，每个部分在该文档中都有自己的选项卡，用于显示该特定部分的运行列表。最近有人提议我们使用 MS Project 跟踪问题打开的时间。我可以从我们的 Excel 选项卡中获取信息并手动将其复制到 Project 中以显示我们想要的内容，如果它是 1:1 Excel 表到项目表，我可以让 Project 自动更新链接的源，但我们只需要 1 个项目表有时，他们需要根据工作簿的打开选项卡进行更新，因此参考会根据我们正在查看的部分而更改。

目标：我正在寻找可以基于单击运行的 Excel 和 Project 中的一个/两个的宏代码，它将 Excel 中的参考单元格复制到 Project。

因此，用户将打开 Excel 并转到他们想要在 Project 中绘制图表的部分的选项卡。然后，他们将能够单击该选项卡中的一个按钮，该按钮 1) 打开格式化的项目文件 2) 选择该 Excel 选项卡上的特定单元格以复制到项目 [例如，在 Excel 行中，BE60:BI60 将复制到第 1 行项目，BE67:BI67 到第 2 行，依此类推]。我可以很容易地从 Excel 中获取宏来打开 Project，但是我正在努力从哪里开始复制基于当前选项卡的链接源。

我已经解决的代码如下：

    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

标签： excelvbareferencems-project

解决方案

这是从 Excel 打开 MS Project 文件并从 Excel 文件中的活动选项卡更新计划的代码。

诀窍是使用 Project Application 对象的Find方法来查找任务，然后设置Task对象变量以简化字段更新。不要费心更新Duration字段，因为它将根据 Start 和 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

推荐阅读