This code opens a bunch of MS Project 2016 documents and dumps the contents into an Excel 2016 sheet. The MS Project file paths are in the range (rng2) C2:C & Last Row. Each time through, the 1101 error is thrown when it reaches the sixth item in the range.
This makes no sense to me, but there must be something wrong with the code. Any ideas?
- The error occurs no matter how the file paths are ordered in the range.
- The code runs to completion when file paths are tested 1 at a time, so I know the paths and files are good.
- A watch shows that the rng2 value is exactly what it should be at time of failure (e.g. the value is set to the desired file path).
This makes no sense to me, but there must be something wrong with the code. Any ideas?
Code:
Sub OpenProjectCopyPasteData()
Dim PrjApp As MSProject.Application
Dim aProg As MSProject.Project
Dim PrjFullName As String
Dim t As Task
Dim rngClr As Range
Dim rngClr2 As Range
Dim rng As Range
Dim rng2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim MyCell As Variant
Dim Lastrow As Long
Set ws1 = Worksheets("MS Project Milestones")
Set ws2 = Worksheets("Active NRE Projects")
Set rngClr = ws1.Range("A:G")
Set PrjApp = New MSProject.Application
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ws1.Activate
'Clear current contents of Project Data tab
rngClr.ClearContents
'Open MS Project file
ws2.Activate
Set rng2 = Sheets("Active NRE Projects").Range("C2")
Do Until IsEmpty(rng2.Value)
PrjApp.FileOpenEx rng2
Set aProg = PrjApp.ActiveProject
' show all tasks
OutlineShowAllTasks
ws1.Activate
'Copy the project columns and paste into Excel
SelectTaskColumn Column:="Name"
EditCopy
Set ws1 = Worksheets("MS Project Milestones")
Set rng = ws1.Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Resource Names"
EditCopy
Set rng = ws1.Range("B" & Cells(Rows.Count, "B").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Finish"
EditCopy
Set rng = ws1.Range("F" & Cells(Rows.Count, "F").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Text1"
EditCopy
Set rng = ws1.Range("C" & Cells(Rows.Count, "C").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Text2"
EditCopy
Set rng = ws1.Range("D" & Cells(Rows.Count, "D").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
With Sheets("MS Project Milestones")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
Lastrow = 1
End If
End With
With Sheets("MS Project Milestones")
.Range("A" & (Lastrow + 1)).Value = "X"
.Range("B" & (Lastrow + 1)).Value = "X"
.Range("C" & (Lastrow + 1)).Value = "X"
.Range("D" & (Lastrow + 1)).Value = "X"
.Range("F" & (Lastrow + 1)).Value = "X"
End With
PrjApp.FileClose False
'PrjApp.Quit pjDoNotSave
'Set PrjApp = Nothing
ws2.Activate
Set rng2 = rng2.Offset(1, 0)
Loop
' reset settings of Excel and MS-Project
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'PrjApp.FileClose False
PrjApp.Quit pjDoNotSave
Set PrjApp = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub