VBA 错误 1101：值无效

Question

此代码打开一堆 MS Project 2016 文档并将内容转储到 Excel 2016 sheet。 MS Project 文件路径在 (rng2) C2:C & Last Row 范围内。每次通过，当它到达范围中的第六项时抛出 1101 错误。在 PrjApp.FileOpenEx rng2.

处失败

无论文件路径在范围。
当文件路径被测试 1 时代码运行完成时间，所以我知道路径和文件都很好。
手表显示 rng2 值正是它在失败时应有的值（例如，该值设置为所需的文件路径）。

这对我来说毫无意义，但代码肯定有问题。有什么想法吗？

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

Answer 1

最好始终指定您正在使用的应用程序对象。

因此请更改对 OutlineShowAllTasks、SelectTaskColumn 和 EditCopy 方法的非限定引用，以便它们明确引用您的 PrjApp Application 对象，例如

PrjApp.OutlineShowAllTasks
'...
PrjApp.SelectTaskColumn Column:="Name"
PrjApp.EditCopy
'... etc

即使它没有避免内存和引用问题，明确指定应用程序也会让其他人更容易理解您的代码 - 通过包含 PrjApp.，他们可以很容易地看到诸如 OutlineShowAllTasks 是 MSProject 方法，它们不会花时间查看您的 Excel 代码来寻找 Sub OutlineShowAllTasks()（这是我第一次看到您的代码时所做的）。

VBA 错误 1101：值无效

VBA Error 1101: Value Not Valid

excel

vba

ms-project