使用 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:\Users\Controls\Desktop\ServiceSchedule.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;@"