Previously Working Code Falling Over After slight modification

Question

Hi All
I have an issue with a piece of code that was working previously.  what I have is that initially I consolidated multiple projects plans into a master plan whilst retaining links and my extract to Excel worked fine.  However I modified my code to
consolidate individual projects plans into an Excel worksheet but this time without retaining the link and it now fails.  There are 1496 tasks in the consolidated plan and it falls over at the end of the first inserted Project.  Here3 is the code:
'Export GIVE and GET Milestones
Row = 1
For Each t In ActiveProject.Tasks
If t.Flag10 = "True" Then 'Flag10 is Deliverable Yes/No
Set s = xlApp.ActiveWorkbook.Worksheets(1)
Set xlRng = s.Range("A3")
If Not t Is Nothing Then
With xlRng
.Range("A" & Row) = t.Text16
.Range("B" & Row) = t.Text12
.Range("C" & Row) = t.Text4
.Range("D" & Row) = t.Name
.Range("E" & Row) = t.PercentComplete
.Range("F" & Row) = t.Finish
End With
End If
If t.Flag10 = "True" Then
Row = Row + 1
End If
End If
Set xlRng = xlRng.Offset(1, 0) 'Point to next row
Next t
The line it falls over on is :
            If t.Flag10 = "True" Then                       'Flag10 is Deliverable
Yes/No
Any help/advice would be appreciated.
Kind regards
Tony
TKHussar

Answer 1

Hi John
The previous version of my code retained the link to each individual Project plan.  On your suggestion I removed the link to the sub project plans.  So when I recorded the macro to consolidate all of the individual plans I removed the tick to retain
a link to the original plans.  In the consolidated plan there are 1496 tasks returned by the ApplicationsProject.Tasks.Count property.  Here is the full version of the code to hopefully help:
Sub ExportGIVEs_GETs()
Dim xlApp As Excel.Application
Dim objRange
Dim xlRng As Excel.Range
Dim Res As Resource
Dim t As Task
Dim s As Worksheet
Dim Row As Integer
Dim LastRow As Integer
'Start Excel and create a new Workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Add
'Create Column Titles
Set xlRng = xlApp.Range("A1")
xlRng.Range("A1") = "EA Release 2 - GIVEs and GETs"
Set xlRng = xlApp.Range("A1")
xlRng.Range("A1").Select
With xlApp.Selection.Font
.Name = "Calibri"
.Size = 22
.Underline = xlUnderlineStyleSingle
.ThemeColor = xlThemeColorLight2
.ThemeFont = xlThemeFontMinor
End With
Set xlRng = xlApp.Range("A1:F1")
xlRng.Range("A1:F1").Select
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.799981682294784
.PatternTintAndShade = 0
End With
Set xlRng = xlApp.Range("E1")
xlRng.Range("A1") = "Issued: "
Set xlRng = xlApp.Range("F1")
xlRng.Range("A1") = "=" & "Today()"
Set xlRng = xlApp.Range("A2")
xlRng.Range("A1").Select
xlRng.Range("A1") = "Workstream"
xlRng.Range("B1") = "UID from Plan"
xlRng.Range("C1") = "Provider/Receiver"
xlRng.Range("D1") = "GIVE/GET Name"
xlRng.Range("E1") = "% Complete"
xlRng.Range("F1") = "Date Required"
Set xlRng = xlApp.Range("A2:F2")
xlRng.Range("A1:G1").Select
With xlApp.Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Set xlRng = xlApp.Range("A2")
xlRng.Range("A1:F1").Select
With xlApp.Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6299648
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Set xlRng = xlApp.Range("A2:F2")
xlRng.Range("A1:F1").Select
With xlApp.Selection
.RowHeight = 40
.VerticalAlignment = xlCenter
End With
xlRng.Range("A1").Select
'Export GIVE and GET Milestones
Row = 1
For Each t In ActiveProject.Tasks
If t.Flag10 = "True" Then 'Flag10 is Deliverable Yes/No
Set s = xlApp.ActiveWorkbook.Worksheets(1)
Set xlRng = s.Range("A3")
If Not t Is Nothing Then
With xlRng
.Range("A" & Row) = t.Text16
.Range("B" & Row) = t.Text12
.Range("C" & Row) = t.Text4
.Range("D" & Row) = t.Name
.Range("E" & Row) = t.PercentComplete
.Range("F" & Row) = t.Finish
End With
End If
If t.Flag10 = "True" Then
Row = Row + 1
End If
End If
Set xlRng = xlRng.Offset(1, 0) 'Point to next row
Next t
'Tidy up
Set xlRng = s.Range("A2")
xlRng.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRng = s.Range("D:E")
xlRng.Range("A:B").Select
With Selection
xlRng.Range("A:B").HorizontalAlignment = xlLeft
xlRng.Range("A:F").EntireColumn.AutoFit
End With
Set xlRng = s.Range("B:G")
With xlRng
xlRng.Range("A:F").EntireColumn.AutoFit
End With
Set xlRng = s.Range("A:A")
xlRng.Range("A:A").ColumnWidth = 25
Set xlRng = s.Range("E2")
xlRng.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRng = s.Range("G2")
xlRng.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRng = s.Range("F:F")
xlRng.Range("A:A").Select
With Selection
xlRng.Range("A:A").NumberFormat = "dd/mm/yy;@"
xlRng.Range("A:A").HorizontalAlignment = xlCenter
End With
'Sort by Workstream Area
Set objRange = xlApp.ActiveWorkbook.Worksheets("Sheet1").Range("A3:F2000")
objRange.Sort Key1:=objRange.Parent.Range("A3"), Key2:=objRange.Parent.Range("D3")
Set xlRng = s.Range("A1")
xlRng.Range("A1").Select
Set xlRng = s.Range("A1:F2000")
With xlApp.ActiveSheet.PageSetup
.Orientation = xlLandscape
.PrintGridlines = True
.PaperSize = xlPaperA3
End With
Set xlApp = Nothing
End Sub
Thanks for your help.
Tony