试图从MS项目文件中运行Excel文件中的宏

Question

我使用了前一个问题中的代码片段(见下文)。

打开现有的Excel文件，并通过MS Project在该文件中运行宏

当我单独运行它时，它工作正常，然而，当我把它放入我的代码时，它停止工作。

为清晰而编辑-当我通过宏并到达应该触发宏的行时:xlApp。运行("'本周报告- BLANK.xlsm'!apply_conditional_formatting")代码只是从顶部传递过去。这个宏包含在excel文件中，它设置一些条件格式并输入一些文本，以提供已触发的视觉确认。这是不会发生的。不会产生任何错误，代码的行为就好像那一行不存在一样。当我进入excel文件并手动触发宏是有效的，所以宏不会引起问题，它只是似乎没有被触发。当在原始代码片段中使用宏时，可以从MS项目文件触发该宏。

谁能告诉我我做错了什么?我的代码如下。我移动了打开excel文件的代码块，更接近宏触发器，以防中间代码中的某些东西阻止它工作，但是这不起作用。

Sub use_excel_based_on_simple()
Dim xlApp As Object

Dim MyXL As Object
Dim Resource As Resource
Dim Version As String
Dim MSP_name As String
Dim finish As Date
Dim Res_name As String
Dim Res_email As String
Dim FileName As String
Dim rows As Integer
Dim xlWkb As Object
Dim myFilePath As String
Dim myfilename As String
Dim xlrange As Variant




On Error Resume Next
OutlineShowAllTasks

SelectBeginning                     ' restart from the beginning
finish = InputBox("Please enter the date for next Friday", "Date entry", Int(Now() + 8)) 'assumes that we will be running this on Thursday

For Each Resource In ActiveProject.Resources
If Not (Resource Is Nothing) Then
If Resource.Work > 0 Then
'setup and apply filter for each resource
FilterEdit name:="filter4people", TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Start", Test:="is less than or equal to", Value:=finish, ShowInMenu:=True, ShowSummaryTasks:=True
FilterEdit name:="filter4people", TaskFilter:=True, FieldName:="", NewFieldName:="% Complete", Test:="is less than", Value:="100%", Operation:="And", ShowSummaryTasks:=True
FilterEdit name:="filter4people", TaskFilter:=True, FieldName:="", NewFieldName:="Resource names", Test:="contains", Value:=Resource.name, Operation:="And", ShowSummaryTasks:=True

FilterApply "filter4people" ' apply the filter
Debug.Print "Resource: " & Resource.ID & "-" & Resource.name & "Error: " & Err.Number
If Not (Err.Number = 91 Or Err.Number = 0) Then            ' saw an error applying filter
'MsgBox "ERROR: " & Err.Description
Debug.Print Resource.name & " ERROR: " & Err.Number & " " & Err.Description
Debug.Print "resource ID: " & Resource.ID
Err.Clear                   ' clear out the error
GoTo NextResource           ' jump to the next resource
End If
Application.SelectSheet 'need to select the sheet so that ActiveSelection works properly
rows = CStr(ActiveSelection.Tasks.Count)
If Err.Number = 424 Then rows = 0 'traps the error which is caused when there is nothing to display in the filter and sets rows so that the file will not be saved.

Res_name = Resource.name
Res_email = Resource.EMailAddress

Version = Format(Now, "yyyy-mmm-dd hh-mm-ss")
myFilePath = ActiveProject.Path
myfilename = myFilePath & "" & "Weekly Look ahead report - " & Res_name & " " & Version & ".xlsm"

'    Set MyXL = CreateObject("Excel.Application")
'    Set xlWkb = MyXL.Workbooks.Open("C:UsersmilesOneDriveSurvitectesting spaceThis week report - BLANK.xlsm")
'    MyXL.Visible = True
'    MyXL.ActiveWorkbook.Worksheets("Sheet1").Activate
'    Set xlrange = MyXL.ActiveSheet.Range("A1")

'Put data to be transfered into array
Dim data() As String
Dim T As Task
Dim Ts As Tasks
Dim r As Integer
If rows > 0 Then
r = 1
Set Ts = ActiveSelection.Tasks
ReDim Preserve data(rows, 7)

For Each T In Ts
If Not (T Is Nothing) Then
data(r, 1) = T.Project
data(r, 2) = T.name
data(r, 3) = T.Start
data(r, 4) = T.finish
data(r, 5) = T.PercentComplete
data(r, 6) = T.ResourceInitials
data(r, 7) = T.Summary
r = r + 1
End If
Next T
Else
GoTo NextResource
End If
Application.SelectBeginning 'remove selection of MS Projct sheet to avoid issues if the user hits delete by accident

'setup excel file
Set MyXL = CreateObject("Excel.Application")
Set xlWkb = MyXL.Workbooks.Open("C:UsersmilesOneDriveSurvitectesting spaceThis week report - BLANK.xlsm")
MyXL.Visible = True
'    MyXL.ActiveWorkbook.Worksheets("Sheet1").Activate
Set xlrange = MyXL.ActiveSheet.Range("A1")

'enter data into excel
xlrange.Range("A2:g" & rows + 1).Value = data()

Set Rng = xlrange.Range("c2:d" & rows + 1)
For Each Cell In Rng.Cells
Cell.Value = DateValue(Cell.Value)
Next Cell

For Each Cell In xlrange.Range("e2:e" & rows + 1).Cells
Cell.Value = Cell.Value * 0.01
Cell.NumberFormat = "0%"
Next Cell
'run macro to apply conditional formatting
xlApp.Run ("'This week report - BLANK.xlsm'!apply_conditional_formatting")

'save file if it contains data
If rows > 0 Then
MyXL.ActiveWorkbook.SaveAs myfilename
MyXL.ActiveWorkbook.Close
Else
MyXL.ActiveWorkbook.Close SaveChanges:=False
End If


MyXL.Quit
'    Set MyXL = Nothing


'email file out to name and email.

End If ' - for work = 0
End If ' - for resource is blank
NextResource:
Next Resource

MyXL.Quit
Set MyXL = Nothing

FilterApply name:="All Tasks"       ' apply the filter
MsgBox ("all done")
End Sub

Answer 1

不深入分析你的代码:你经常使用"活动的…"——像ActiveWorkbook或ActiveSelection这样的项目。这将导致一个错误，只要焦点转移到不同的项目，例如在Excel和项目之间切换。定义一个变量并将"Active…"存储在其中，然后在代码中只引用变量!

Answer 2

可悲的是，这一切都归结为愚蠢。我已经编辑了从xlApp到MyXL的代码片段，以便与其他代码匹配，但没有更改

xlApp.Run ("'This week report - BLANK.xlsm'!apply_conditional_formatting") 

匹配:(将其更改为read

MyXL.Run ("'This week report - BLANK.xlsm'!apply_conditional_formatting") 

。