项目VBA选择没有ActiveSelection的任务

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

目前，最终将在Excel图表中完成的任务是通过在项目中突出显示它们然后运行宏来选择的。我反而希望宏能够通过查看该组的第一个和最后一个任务来选择这些任务。我的意思是我希望能够读取任务名称，找到任务名称“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

来源

2016-06-08 mithirich

显示宏。显示示例数据。我们无法猜测您所写的内容或数据的样子 – dbmitch

抱歉。上面添加了它。 – mithirich

好吧我想通了一些。不是我最初的想法，但它的工作。我使用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;@"

来源

2016-06-10 12:32:04 mithirich

项目VBA选择没有ActiveSelection的任务

回答

相关问题