使用Project VBA选择"不带ActiveSelection的任务"

Question

我接受一个项目，并将所选任务导出到Excel中的甘特图中。

最终出现在Excel图表中的任务是通过在Project中突出显示它们然后运行宏来选择的。我希望宏通过查看该组的第一个和最后一个任务来选择这些任务。我的意思是，我想读取任务名称，找到任务名称"A"，然后处理所有任务，直到它达到任务名称"Z"。

我尝试使用任务ID来设置ID号，但每当向项目中添加新任务时，任务号就会更改。我也尝试过使用唯一ID，但这不起作用，因为A和Z之间的一些任务已经在项目中存在了一段时间，所以设置特定的范围也不起作用。

我觉得有一个简单的方法可以做到这一点，但我还没有偶然发现。

编辑：添加了以下代码。相关部分就在注释"用任务信息填充单元格"的下方。

Sub ExportToExcel()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim proj As Project
Dim t As Task
Dim pj As Project
Dim pjDuration As Integer
Dim i As Integer
Dim k As Integer
Dim c As Range
Set pj = ActiveProject
Set xlApp = New Excel.Application
'AppActivate "Excel"
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open("C:UsersControlsDesktopServiceSchedule.xlsx")
xlApp.WindowState = xlMaximized
'Set up Project Detail Headers
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Application.ScreenUpdating = False
xlSheet.Application.DisplayAlerts = False
xlSheet.UsedRange.Delete
xlSheet.Cells.Clear
xlSheet.Cells.ClearContents
'xlSheet.Cells(1, 1).Value = "Project Name"
'xlSheet.Cells(1, 2).Value = pj.Name
'xlSheet.Cells(2, 1).Value = "Project Title"
'xlSheet.Cells(2, 2).Value = pj.Title
'xlSheet.Cells(1, 4).Value = "Project Start"
'xlSheet.Cells(1, 5).Value = pj.ProjectStart
'xlSheet.Cells(2, 4).Value = "Project Finish"
'xlSheet.Cells(2, 5).Value = pj.ProjectFinish
'Set Gantt Chart Timespan
'xlSheet.Cells(1, 7).Value = "Project Duration"
pjDuration = 90
'xlSheet.Cells(1, 8).Value = pjDuration & "d"
'Set up Headers
xlSheet.Cells(4, 1).Value = "Task ID"
xlSheet.Cells(4, 2).Value = "Task Name"
xlSheet.Cells(4, 3).Value = "Name"
xlSheet.Cells(4, 4).Value = "Task Start"
xlSheet.Cells(4, 5).Value = "Task Finish"
xlSheet.Cells(4, 1).Font.Bold = True
xlSheet.Cells(4, 2).Font.Bold = True
xlSheet.Cells(4, 3).Font.Bold = True
xlSheet.Cells(4, 4).Font.Bold = True
xlSheet.Cells(4, 5).Font.Bold = True
'Freeze Rows & Columns
xlSheet.Range("F5").Select
xlSheet.Application.ActiveWindow.FreezePanes = True
'AutoFit Header columns and Hide blank rows
xlSheet.Columns("A:E").AutoFit
xlSheet.Columns("A").Hidden = True
xlSheet.Rows("1:2").Hidden = True
' Add day of the week headers for the entire Project's duration
For i = 0 To pjDuration
'If Today's Date is Sunday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 1 Then
xlSheet.Cells(3, i + 6).Value = Now() + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = Now() + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Monday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 2 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 1) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 1) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Tuesday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 3 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 2) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 2) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Wednesday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 4 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 3) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 3) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Thursday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 5 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 4) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 4) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Friday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 6 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 5) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 5) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Saturday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 7 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 6) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;@"
xlSheet.Cells(4, i + 6).Value = (Now() - 6) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'Color Weekend columns
xlSheet.Cells(4, i + 6).ColumnWidth = 10
If xlSheet.Application.Cells(4, i + 6).Text = "Sat" Then
For k = 1 To 100
xlSheet.Cells(4 + k, i + 6).Interior.ColorIndex = 15
Next
End If
If xlSheet.Application.Cells(4, i + 6).Text = "Sun" Then
For k = 1 To 100
xlSheet.Cells(4 + k, i + 6).Interior.ColorIndex = 15
Next
End If
Next
'Merge date cells
For i = 0 To pjDuration Step 7
xlSheet.Cells(3, i + 6).Select
xlSheet.Application.ActiveCell.Resize(1, 7).Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.Merge
Next i    
'Fill cells with Task information
Dim SearchString1 As String
Dim SearchString2 As String
SearchString1 = "Buyoffs/Service"
SearchString2 = "History"
**For Each t In ActiveSelection.Tasks
xlSheet.Cells(t.ID + 4, 1).Value = t.ID
xlSheet.Cells(t.ID + 4, 2).Value = t.Name
xlSheet.Cells(t.ID + 4, 3).Value = t.ResourceNames
xlSheet.Cells(t.ID + 4, 4).Value = t.Start
xlSheet.Cells(t.ID + 4, 4).NumberFormat = "[$-409]mm-dd-yy;@"
xlSheet.Cells(t.ID + 4, 5).Value = t.Finish
xlSheet.Cells(t.ID + 4, 5).NumberFormat = "[$-409]mm-dd-yy;@"**
'Loop to color cells to mimic Gantt chart
For i = 5 To pjDuration + 5
If t.Start <= xlSheet.Cells(4, i + 1) And t.Finish >= xlSheet.Cells(4, i + 1) Then
xlSheet.Cells(t.ID + 4, i + 1).Interior.ColorIndex = 37
With xlSheet.Cells(t.ID + 4, i + 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
End If
Next i
Next t
'Loop To Change Day Headers to Single Char Format
For i = 0 To pjDuration
With xlSheet.Cells(4, i + 6)
If .Text = "Sun" Then
.Value = "S"
ElseIf .Text = "Mon" Then
.Value = "M"
ElseIf .Text = "Tue" Then
.Value = "T"
ElseIf .Text = "Wed" Then
.Value = "W"
ElseIf .Text = "Thu" Then
.Value = "R"
ElseIf .Text = "Fri" Then
.Value = "F"
ElseIf .Text = "Sat" Then
.Value = "S"
End If
End With
xlSheet.Cells(4, i + 6).ColumnWidth = 1.5
Next
'Remove empty rows
xlSheet.Range("A5:A10000").AutoFilter 1, "<>", , , False
'Autofit Columns
xlSheet.Columns("B:E").AutoFit
xlSheet.Columns("B:B").Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.ColumnWidth = 50
With xlSheet.Application.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With    
'Format Cells with Borders
xlSheet.Rows("4:4").Select
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlEdgeRight).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlInsideVertical).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
xlSheet.Columns("E:E").Select
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlInsideVertical).LineStyle = xlNone
xlSheet.Range("F4:CR4").Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With xlSheet.Application.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With xlSheet.Application.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
xlApp.Visible = True
xlBook.Save
xlSheet.Application.DisplayAlerts = True
xlSheet.Application.ScreenUpdating = True
xlSheet.Application.ActiveWindow.Zoom = 100
End Sub

Answer 1

好吧，我想好了。不是我最初想的那样，但它起了作用。我使用Project的WBS属性跳过任何大纲级别为"1"的任务。所以它将从大纲级别"2"开始，其中包含我想要的内容。结束循环很容易，因为我只需要一个If语句，当它遇到最后一个任务名称时，就可以跳出循环。

For Each t In ActiveProject.Tasks
If t.Name = "History" Then
Exit For
End If
If t.Name = "Vacations" Then
TaskA = t.ID
End If
If t.Name = "Buyoffs/Service" Then
TaskB = t.ID
End If
If t.Name = "Buyoffs/Service" Then GoTo NextIteration
TaskOffset = TaskB - TaskA + 1
If t.Name = "Vacations" Then GoTo NextIteration
If t.Name = "Unscheduled" Then GoTo NextIteration
If InStr(1, t.WBS, "1.") Then GoTo NextIteration
xlSheet.Cells(t.ID + 4 - TaskOffset, 1).Value = t.ID
xlSheet.Cells(t.ID + 4 - TaskOffset, 2).Value = t.Name
xlSheet.Cells(t.ID + 4 - TaskOffset, 3).Value = t.ResourceNames
xlSheet.Cells(t.ID + 4 - TaskOffset, 4).Value = t.Start
xlSheet.Cells(t.ID + 4 - TaskOffset, 4).NumberFormat = "[$-409]mm-dd-yy;@"
xlSheet.Cells(t.ID + 4 - TaskOffset, 5).Value = t.Finish
xlSheet.Cells(t.ID + 4 - TaskOffset, 5).NumberFormat = "[$-409]mm-dd-yy;@"