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
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.