miless2111s
Active Member
- Joined
- Feb 10, 2016
- Messages
- 279
- Office Version
- 365
- 2016
- Platform
- Windows
I am attempting to produce some VBA in MS project to:
I have been using some code I produced a very long time ago which didn't have to iterate and open and close many Excel files and I wonder if this is what is giving me trouble.
At the moment I have three key issues;
My code:
- Open a new instance of Excel
- Set up some columns
- Apply a filter in MSP and copy the contents
- Paste into the opened Excel file
- Save the Excel file
- Close the excel file
I have been using some code I produced a very long time ago which didn't have to iterate and open and close many Excel files and I wonder if this is what is giving me trouble.
At the moment I have three key issues;
- The paste command doesn't work. I have tried many types of paste and they either result in a picture including the Gantt chart being pasted in or nothing happens.
- The middle of three resources seems to be missed out - I suspect some error is happening which results in the loop being abandoned.
- I get multiple errors:
- Error: Invalid Procedure call or Argument
- Error: Object variable or With clock variable not set.
My code:
VBA Code:
Sub emailFilteredResources()
Dim MyXL As Object
Dim Version As String
Dim MSP_name As String
Dim finish As Date
Dim name As String
Dim email As String
On Error Resume Next ' keep going on an error
'message box asking for date for next friday
finish = InputBox("Please enter the date for next Friday", "Date entry", Int(Now() + 8)) 'assumes that we will be running this on Thursday
'display all tasks
OutlineShowAllTasks
SelectBeginning ' restart from the beginning
For Each Resource In ActiveProject.Resources
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
If (Err.Number) Then ' saw an error applying filter
MsgBox "ERROR: " & Err.Description
Err.Clear ' clear out the error
GoTo NextResource ' jump to the next resource
End If
End If
'gather date from resource (name, email) as variables to be called later
name = Resource.name
email = Resource.EMailAddress
'Copy data from the view
SelectAll
EditCopy
rows = CStr(ActiveSelection.Tasks.Count)
Debug.Print name
Debug.Print email
'setup excel file
'Set the file version using time stamp. Would be nice to have a-z rather than h:m:s but that can follow
Version = Format(Now, "yyyy-mmm-dd hh-mm-ss")
'find the current project's path and set the file name for the excel file to be produced
myFilePath = ActiveProject.Path
myfilename = myFilePath & "\" & name & " " & Version & ".xlsx"
Set MyXL = CreateObject("Excel.Application")
MyXL.Workbooks.Add
'MyXL.workbooks.Add.Name = "Exceptions.xlsx"
MyXL.Visible = True
MyXL.ActiveWorkbook.Worksheets.Add.name = "Weekly look ahead"
MyXL.ActiveWorkbook.Worksheets("Weekly look ahead").Activate
Set xlrange = MyXL.ActiveSheet.Range("A1")
'set the page titles in Excel
xlrange.Range("o1") = "Start"
xlrange.Range("o2") = "Finish"
xlrange.Range("p1") = finish - 7
xlrange.Range("p2") = finish
xlrange.Range("r1") = "key"
xlrange.Range("r2") = "Late"
xlrange.Range("r3") = "Finishing this week"
xlrange.Range("r4") = "Starting this week"
xlrange.Range("r5") = "In play this week"
'Set formats for colour key
xlrange.Range("R2").Font.ColorIndex = 2
xlrange.Range("r2").Interior.ColorIndex = 3
xlrange.Range("r3").Interior.ColorIndex = 45
xlrange.Range("r4").Interior.ColorIndex = 43
xlrange.Range("r5").Interior.ColorIndex = 15
'paste in values to excel file THIS IS THE ISSUE!!
'xlrange.Range("a1").Paste '- nothing
'ActiveSheet.Paste Destination:=xlrange.Range("A1:g" & rows + 1) '- nothing
'xlrange.Range("A1:g" & rows + 1).PasteSpecial Paste:=xlpastevalues '- paste picture
'xlrange.Range("A:G").PasteSpecial xlPasteValues '- paste picture
'xlrange.Range("A1:g" & rows + 1).Paste '- nothing pastes
xlrange.Select
ActiveSheet.Paste '-nothing again :(
'put conditional formatting in place in excel
'set column widths
With MyXL.ActiveWorkbook.Worksheets("Weekly look ahead")
.Columns("A:R").AutoFit
End With
xlrange.Columns("A:A").ColumnWidth = 100
xlrange.Columns("A:A").EntireColumn.AutoFit
With xlrange.Range("a1:G" & row + 1)
.WrapText = True
.EntireRow.AutoFit
End With
'save excel file
MyXL.ActiveWorkbook.SaveAs myfilename
MyXL.ActiveWorkbook.Close
MyXL.Quit
Set MyXL = Nothing
'send excel file
'shift focus back to MS Project
AppActivate "Microsoft Project"
NextResource:
Next Resource
FilterApply name:="All Tasks" ' apply the filter
End Sub