Question

此代码打开一堆MS Project 2016文档，并将内容转储到Excel 2016工作表中。 MS Project文件路径在范围（rng2）C2：C＆amp;最后一行。每次通过，当它到达范围中的第六项时，抛出1101错误。在PrjApp.FileOpenEx rng2失败。

无论文件路径如何排序，都会发生错误范围。
当文件路径在a处测试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

最好始终指定您正在使用的Application对象。

因此，请更改对OutlineShowAllTasks，SelectTaskColumn和EditCopy方法的无保留引用，以便它们明确引用您的PrjApp应用程序对象，例如

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

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

VBA错误1101：值无效

1 个答案: