我使用了上一个问题的代码片段(见下文)。
打开一个现有的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
2条答案
按热度按时间4ioopgfo1#
如果不深入分析代码:您经常使用“Active...”-像ActiveWorkbook或ActiveSelection这样的项目。这将导致一个错误,只要焦点转到一个不同的项目,例如。在Excel和Project之间切换。定义一个变量,并将“Active...”存储在其中,然后在代码中仅引用该变量!
arknldoa2#
可悲的是,这都是愚蠢的结果。我已经编辑了从xlApp到MyXL的代码片段,以与其他一些代码相匹配,但没有更改
匹配:(将此更改为阅读
成功了