Как сделать макрос во вкладке книги Excel, чтобы открыть MS Project и скопировать ссылочные ячейки - PullRequest
Новая
       61

Как сделать макрос во вкладке книги Excel, чтобы открыть MS Project и скопировать ссылочные ячейки

0 голосов
/ 05 марта 2020

Ситуация : у нашей компании есть список открытых вопросов, который мы используем для отдельных частей во время испытаний / запуска программы. Программа имеет свой собственный документ Excel, и каждая часть имеет свою вкладку в этом документе для рабочего списка этой указанной c части. Недавно было предложено, чтобы мы отслеживали, как долго проблемы открыты, используя MS Project. Я могу взять информацию из нашей вкладки Excel и вручную скопировать ее в Project, чтобы показать, что мы хотим, и я могу сделать так, чтобы Project автоматически обновлял связанные источники, если это лист Excel 1: 1 для листа Project, но нам нужен только 1 лист Project в время, и они должны обновляться на основе открытой вкладки рабочей книги, поэтому ссылки меняются в зависимости от того, на какую часть мы смотрим.

Цель : я ищу макрос код для / или Excel, и для Project, который может быть запущен на основе одного щелчка, при котором ячейки ссылок в Excel копируются в Project.

Таким образом, пользователи откроют Excel и go на вкладке часть они хотят диаграмму в проекте. Затем они смогут нажать кнопку на этой вкладке, которая 1) открывает отформатированный файл проекта 2) выбирает определенные c ячейки на этой вкладке Excel для копирования в Project [например, в строках Excel BE60: BI60 будет копировать в строку 1 проекта, BE67: BI67 в строку 2 и т. д.]. Я могу заставить макрос открывать Project достаточно легко из Excel, но я не могу понять, с чего начать копирование источника ссылок на основе текущей вкладки.

Ниже приведен код решения, с которым я работал: 

    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 Ответ

0 голосов
/ 06 марта 2020

Вот код, который открывает файл MS Project из Excel и обновляет расписание с активной вкладки в файле Excel.

Хитрость заключается в том, чтобы использовать метод Find объекта Project Project для поиска задачи, а затем установить переменную объекта Task , чтобы упростить обновление полей. Не беспокойтесь об обновлении поля Duration , так как оно будет рассчитано на основе Start и Fini sh. 

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
...