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

20jt8wwn  于 2023-10-22  发布在  其他
关注(0)|答案(2)|浏览(123)

我使用了上一个问题的代码片段(见下文)。
打开一个现有的Excel文件,并通过MS Project运行该文件中的宏
当我自己运行它时,它工作得很好,但是,当我把它放到代码中时,它就停止工作了。
为了清晰起见,我进行了编辑-当我遍历宏时,它到达了应该触发宏的行:运行(“'本周报告- BLANK. xlsm'!apply_conditional_formatting”)代码只是越过顶部。这个宏包含在excel文件中,设置一些条件格式,并输入一些文本以提供视觉确认它已被触发。这是不可能的。不会产生任何错误,代码的行为就像特定的行不存在一样。当我进入excel文件并手动触发宏时,宏不会引起问题,它只是看起来没有被触发。当在原始代码片段中使用时,可以从MS Project文件触发宏。
谁能告诉我我做错了什么?代码在下面。我把打开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
4ioopgfo

4ioopgfo1#

如果不深入分析代码:您经常使用“Active...”-像ActiveWorkbook或ActiveSelection这样的项目。这将导致一个错误,只要焦点转到一个不同的项目,例如。在Excel和Project之间切换。定义一个变量,并将“Active...”存储在其中,然后在代码中仅引用该变量!

arknldoa

arknldoa2#

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

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

匹配:(将此更改为阅读

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

成功了

相关问题