Select Tasks without ActiveSelection using Project VBA

0
votes

I take a project and export selected tasks into a Gantt chart in Excel.

The tasks that end up in the Excel chart are selected by highlighting them in Project and then running the macro. I would like for the macro to select these tasks by looking at the first and last task of that group. What I mean is I'd like to read the task names, find Task Name "A" and then process all the tasks afterwards until it hits Task Name "Z".

I tried to use the Task ID to set the ID numbers but the task number will change whenever new tasks are added to the project. I also tried using the unique ID but that won't work since there are some tasks between A and Z that have been in the project for a while so setting a specific range for that wouldn't work either.

I feel there is a simple way to do this but I just haven't stumbled upon it yet.

EDIT: Added the code below. The relevant section is just below the comment "Fill cells with Task information".

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
1
excelvbams-project
show the macro. show the sample data. we can't guess at what you've written or what the data looks like – dbmitch
Sorry. Added it above. – mithirich

1 Answers

0
votes

Okay I figured something out. Not the way I initially had in mind but it worked. I used the WBS property of Project to skip any task with outline level "1". So it would start at outline level "2" which contained what I wanted. Ending the loop was easy sine I just needed an If statement to jump out of the loop when it came across that last task name.

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;@"