excelvbams-project

Attempting to run a macro in an Excel file from within an MS Project file


I have used a code snippet from a previous question (see below).

Open an existing Excel file and run a macro in that file through MS Project

When I run it on its own it works OK, however, when I put it into my code it stops working.

Edited for clarity - when I step through the macro and it gets to the line which should trigger the macro: xlApp.Run ("'This week report - BLANK.xlsm'!apply_conditional_formatting") The code just passes over the top. This macro is contained in the excel file and sets some conditional formatting and enters some text to provide visional confirmation that it has been triggered. This does not happen. No errors are produced, the code just behaves as if that specific line doesn't exist. When I go into the excel file and manually trigger the macro is works so the macro isn't causing an issue, it just doeesn't appear to be triggered. When used in the original code snippet the macro can be triggered from the MS Project file.

Can anyone tell me what I have done wrong? My code is below. I moved the block of code that opens the excel file closer to the macro trigger in case something in the intervening code was preventing it from working however this didn't work.

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

Solution

  • It was all down to stupidity sadly. I had edited the code snippet from xlApp to MyXL to match in with some other code but hadn't changed the

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

    to match :( Changing this to read

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

    worked.