尝试从 MS Project 文件中运行 Excel 文件中的宏

Question

我使用了上一个问题中的代码片段（见下文）。

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

当我单独运行它时，它工作正常，但是，当我将它放入我的代码中时，它停止工作。

为清楚起见进行了编辑 - 当我单步执行宏并到达应触发宏的行时： xlApp.Run("'本周报告-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:\Users\miles\OneDrive\Survitec\testing space\This 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:\Users\miles\OneDrive\Survitec\testing space\This 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 和 Project 之间切换。 定义一个变量并将“Active…”存储在其中，然后在代码中仅引用变量！

Answer 2

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

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

匹配:( 将其更改为阅读

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

成功了。