项目VBA选择没有ActiveSelection的任务

Question

我编写了一个宏来获取一个项目并将所选任务导出到excel中的甘特图（出于多种原因）。它工作正常，但我有一个最后的调整我想做，但我正在努力弄清楚如何。

目前，通过在项目中突出显示它们然后运行宏来选择将在Excel图表中结束的任务。我希望宏能够通过查看该组的第一个和最后一个任务来选择这些任务。我的意思是我希望能够阅读任务名称，找到任务名称＆＃34; A＆＃34;然后处理所有任务，直到它命中任务名称＆＃34; Z＆＃34;。

我尝试使用任务ID设置ID号，但只要将新任务添加到项目中，任务编号就会发生变化。我也尝试过使用唯一的ID，但由于A和Z之间的某些任务已经在项目中存在了一段时间，因此无法工作，因此设置一个特定的范围也无法工作。

我觉得有一种简单的方法可以做到这一点，但我还没有偶然发现它。关于如何实现这一目标的任何建议都将不胜感激。

编辑：添加以下代码。相关部分正好在评论下面，并且＃34;使用任务信息＆＃34;填充单元格。感谢

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属性跳过任何大纲级别＆＃34; 1＆＃34;的任务。所以它将从大纲级别开始＆＃34; 2＆＃34;其中包含了我想要的东西。结束循环很简单，我只需要一个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;@"