I have a piece of code that extracts data from MS project and places it in an Excel worksheet. This is working perfectly well with the exception of the sorting part of the code. It works perfectly the first time I run it, but when I run it
the second time it fails on the line identified in the code copied below. Any help/advice on a resolution would be appreciated.
Sub ExportDeliverables()
Dim xlApp As Excel.Application
Dim xlRange 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 xlRange = xlApp.Range("A1")
xlRange.Range("A1") = "TR Stage 2 - Deliverables Dashboard"
Set xlRange = xlApp.Range("A1")
xlRange.Range("A1").Select
With xlApp.Selection.Font
.Name = "Calibri"
.Size = 22
.Underline = xlUnderlineStyleSingle
.ThemeColor = xlThemeColorLight2
.ThemeFont = xlThemeFontMinor
End With
Set xlRange = xlApp.Range("A1:J1")
xlRange.Range("A1:J1").Select
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Set xlRange = xlApp.Range("H1")
xlRange.Range("A1") = "Issued: "
Set xlRange = xlApp.Range("I1")
xlRange.Range("A1") = "=" & "Today()"
Set xlRange = xlApp.Range("A2")
xlRange.Range("A1").Select
xlRange.Range("A1") = "CPP Unique ID"
xlRange.Range("B1") = "Workstream"
xlRange.Range("C1") = "Deliverable"
xlRange.Range("D1") = "Forecast Available Date"
xlRange.Range("E1") = "Actual Publish Date"
xlRange.Range("F1") = "Deliver To"
xlRange.Range("G1") = "Reqd Authority Action"
xlRange.Range("H1") = "Notes"
Set xlRange = xlApp.Range("A2:G2")
xlRange.Range("A1:G1").Select
With xlApp.Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Set xlRange = xlApp.Range("A2")
xlRange.Range("A1:J1").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 xlRange = xlApp.Range("A2:K2")
xlRange.Range("A1:K1").Select
With xlApp.Selection
.RowHeight = 40
.VerticalAlignment = xlCenter
End With
xlRange.Range("A1").Select
'Export Resource Names and the Project Title
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 xlRange = s.Range("A3")
If Not t Is Nothing Then
With xlRange
.Range("A" & Row) = t.UniqueID
.Range("B" & Row) = t.Text28 'Workstream
.Range("C" & Row) = t.Name
.Range("D" & Row) = t.Start 'Forecast Available Date
.Range("E" & Row) = t.Date1 'Actual Publish date
.Range("F" & Row) = t.Text20 'Deliver to
.Range("G" & Row) = t.Text14 'Required Authority Action
.Range("H" & Row) = t.Notes
End With
End If
If t.Flag10 = "True" Then
Row = Row + 1
End If
End If
Set xlRange = xlRange.Offset(1, 0) 'Point to next row
Next t
'Tidy up
Set xlRange = s.Range("A2")
xlRange.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRange = s.Range("D:E")
xlRange.Range("A:B").Select
With Selection
xlRange.Range("A:B").NumberFormat = "dd/mm/yy;@"
xlRange.Range("A:B").HorizontalAlignment = xlCenter
End With
Set xlRange = s.Range("B:G")
With xlRange
xlRange.Range("A:F").EntireColumn.AutoFit
End With
Set xlRange = s.Range("D:E")
xlRange.Range("A:B").ColumnWidth = 10
Set xlRange = s.Range("I:I")
xlRange.Range("A:A").ColumnWidth = 14
Set xlRange = s.Range("D2")
xlRange.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRange = s.Range("E2")
xlRange.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
Set xlRange = s.Range("G2")
xlRange.Range("A1").Select
With xlApp.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
End With
'******************************************************
Set xlRange = s.Range("A2:H200")
xlRange.Range("A2:H200").Select
xlApp.ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
'Code fails on the next row at the second time of running. Works fine the first time!!!!
xlApp.ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:H200")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
'******************************************************
' Set xlRange = s.Range("A3:H200")
' xlRange.Range("A1:H200").Select
' With xlApp.Selection
' ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
' ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B200") _
' , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
' With ActiveWorkbook.Worksheets("Sheet1").Sort
' .SetRange Range("A2:H200")
' .Header = xlYes
' .MatchCase = False
' .Orientation = xlTopToBottom
' .SortMethod = xlPinYin
' .Apply
' End With
' End With
Set xlRange = s.Range("A1")
xlRange.Range("A1").Select
Set xlRange = s.Range("A1:H200")
With xlApp.ActiveSheet.PageSetup
.Orientation = xlLandscape
.PrintGridlines = True
.PaperSize = xlPaperA3
End With
Set xlApp = Nothing
End Sub