MS 프로젝트 개선 VB/VBA 작업 생성

Question

지금은 새로운 작업을 만드는 코드가 있지만 실제로 버그가 있고 일관성이 없습니다.

Public Sub Create_milestones() 
    proj = Globals.ThisAddIn.Application.ActiveProject 

    Dim myTask As MSProject.Task 

    Application.ScreenUpdating = False 

    For Each myTask In Application.ActiveSelection.Tasks 
     Application.SelectTaskField(Row:=1, Column:="Name") 
     Application.InsertTask() 
     Application.SetTaskField(Field:="Duration", Value:="0") 
     Application.SetTaskField(Field:="Start", Value:=myTask.Finish) 
     Application.SetTaskField(Field:="Name", Value:=myTask.Name & " - Milestone") 
     Application.SetTaskField(Field:="Resource Names", Value:=myTask.ResourceNames) 
     Application.SetTaskField(Field:="Text3", Value:="Milestone") 
     Application.GanttBarFormat(GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0) 
     Application.SelectTaskField(Row:=1, Column:="Name") 
    Next 
    Application.SelectTaskField(Row:=-1, Column:="Name") 
    Application.SelectRow(Row:=0) 
    Application.RowDelete() 

    Application.ScreenUpdating = True 

    MsgBox("Done") 
End Sub 

선택한 작업을 통해 너무 멀리 루핑 때가는 것 1 개 작업이 너무 많은, 내가 다시 가서 여분의 작업을 삭제하여이 문제를 해결했다 만들지 만 그것은 나에게 가장 좋은 방법은 아닌 것 같아

.

이 코드는 VB.net에 있다는 것을 알았지 만 VBA에서도 사용할 수 있습니다.

새로운 작업을 만들고 값을 할당하는 더 좋은 방법이 있습니까?

Answer 1

추가 작업의 문제점은 선택한 작업의 컬렉션 (또는 넷 목록)을 저장 한 다음이를 반복하여 해결할 수 있습니다. VBA에서 다른 시청자와 가장 관련성이 높은 솔루션을 게시하고 있습니다. 필요한 경우 vb.net 버전을 게시 할 수 있습니다.

Application.ScreenUpdating = False 

Dim proj As Project 
Set proj = Application.ActiveProject 

Dim myTask As Task 
Dim colTasks As New Collection 
For Each myTask In Application.ActiveSelection.Tasks 
    colTasks.Add myTask, CStr(myTask.UniqueID) 
Next myTask 

Dim i As Object 
For Each i In colTasks 
    Set myTask = ActiveProject.Tasks.UniqueID(i) 
    Dim newTask As Task 
    Set newTask = ActiveProject.Tasks.Add(myTask.Name & " - Milestone", myTask.ID + 1) 
    newTask.Duration = 0 
    newTask.Predecessors = myTask.ID & "FF" 
    newTask.Text3 = "Milestone" 
    newTask.ResourceNames = myTask.ResourceNames 
    Application.SelectRow newTask.ID, False 
    Application.GanttBarFormat GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0 
Next 

Application.SelectRow colTasks(1), False 
Application.SelectTaskField Row:=0, Column:="Name" 
Application.ScreenUpdating = True 

내가 몇 가지 변화 : 1) 시작 필드를 하드 코딩하는 것이 아니라, 그것의 작업과 그것을 유지하는 작업 관계를 사용을 할 때 작업 이동; 2) 무중단 업무는 아무 일도 없기 때문에, 자원을 추가 할 필요가 없습니다. vb.net 버전을 얻을 수있을 것입니다, 그것을위한

 Dim ProjApp As MSProject.Application = Globals.ThisAddIn.Application 
     ProjApp.ScreenUpdating = False 

     Dim proj As MSProject.Project = ProjApp.ActiveProject 

     Dim selTasks As New List(Of MSProject.Task) 
     For Each myTask As MSProject.Task In ProjApp.ActiveSelection.Tasks 
      selTasks.Add(myTask) 
     Next myTask 

     For Each myTask In selTasks 
      Dim newTask As MSProject.Task = proj.Tasks.Add(myTask.Name & " - Milestone", myTask.ID + 1) 
      newTask.Duration = 0 
      newTask.Predecessors = myTask.ID & "FF" 
      newTask.Text3 = "Milestone" 
      newTask.ResourceNames = myTask.ResourceNames 
      ProjApp.SelectRow(newTask.ID, False) 
      ProjApp.GanttBarFormat(GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0) 
     Next 

     ProjApp.SelectRow(selTasks(0).ID, False) 
     ProjApp.SelectTaskField(Row:=0, Column:="Name") 
     ProjApp.ScreenUpdating = True