Question

我每天遇到一次或两次随机问题，该脚本每天从早上7点到下午5点每2分钟运行一次，希望这里的人能够确定是什么原因造成的。

由于该过程使用了3个单独的脚本，因此我将尽量使这篇文章井井有条，并切合实际。

脚本＃1 位于PERSONAL.XLSB工作簿中，并且是在上午7点开始该过程并每120秒重复一次的计时器。下面的代码：

**ThisWorkbook:
Private Sub Workbook_Open()
Application.OnTime TimeValue("07:00:00"), "'RunScripts2'"
End Sub

**Module1:
Sub RunScripts2()
On Error Resume Next
Shell "wscript ""R:\xxxx\xxxx\xxxx\scripts2.vbs""", vbNormalFocus
Dim scr As ScriptControl: Set scr = New ScriptControl
scr.Language = "VBScript"
Application.OnTime DateAdd("s", 120, Now), "RunScripts2"
End Sub

脚本＃2 是脚本＃1每120秒调用一次的scripts2.VBS脚本。这将打开一个excel工作簿并运行宏“ RunCopyPaste”。下面的代码：

**scripts2.vbs:
Option Explicit
On Error Resume Next
ExcelMacroExample
Sub ExcelMacroExample() 

  Dim xlApp 
  Dim xlBook 
  Set xlApp = GetObject(,"Excel.Application") 
  xlApp.Visible = True
  xlApp.DisplayAlerts = False

  Set xlBook = xlApp.Workbooks.Open("\\xxxx\xxxx\xxxx\Model.xlsm",3,True) 

  Dim dteWait
  dteWait = DateAdd("s", 8, Now())
  Do Until (Now() > dteWait)
  Loop

  xlApp.Run "RunCopyPaste"

  Set xlApp = GetObject(,"Excel.Application") 

End Sub

脚本＃3 位于脚本＃2调用的Model.xlsm工作簿中。下面的代码：

**ThisWorkbook:
Private Sub Workbook_Open()
    Application.Run "BloombergUI.xla!RefreshAllWorkbooks"
    Application.Run "BloombergUI.xla!RefreshAllStaticData"
End Sub

**Module2:
Sub RunCopyPaste()
    On Error Resume Next
    Application.DisplayAlerts = False

    ChDir _
        "R:\xxxx\xxxx\xxxx\xxxx\"
    Workbooks.Open Filename:= _
        "R:\xxxx\xxxx\xxxx\xxxx\Data.xlsx" _
        , UpdateLinks:=3, ReadOnly:=True
    Application.Run "ConnectChartEvents"
    Windows("Model.xlsm").Activate
    Sheets("Sheet1").Select
    Range("B5:J94").Select
    Selection.Copy
    Windows("Data.xlsx").Activate
    Sheets("Sheet1").Select
    Range("B5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Windows("Model.xlsm").Activate
    Sheets("Sheet2").Select
    Range("C5:D73").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Data.xlsx").Activate
    Sheets("Sheet2").Select
    Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Windows("Model.xlsm").Activate
    Sheets("Sheet3").Select
    Range("B6:C7").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Data.xlsx").Activate
    Sheets("Sheet3").Select
    Range("B6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


FN = Replace(ActiveWorkbook.Name, "temp_", "")
FN = "temp_" + FN

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + Application.PathSeparator + FN

    ActiveWindow.Close False
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Sheet1").Select
    ActiveWorkbook.Close
Dim wb As Workbook
Set wb = Workbooks.Add

End Sub

我当前面临的问题

此过程效果很好；但是，一旦在SaveAs“ temp_Data.xlsx”过程中中断，它将无法正确保存，除非我杀死excel并重新启动“ RunScripts2”宏。休息时间通常发生在一天中的中午12点至2点之间。这是完全随机的。这就是实际发生的情况：该过程将按预期运行，但是当它到达SaveAs“ temp_Data.xlsx”时，它将显示加载条，显示保存进度比平时快得多（〜.2秒），然后关闭所有工作簿，打开一片空白，然后在120秒后重复该过程。但是，我注意到“ temp_Data.xlsx”显示了“修改日期”，以反映先前的运行。一旦“中断”，随后的每次运行都将看起来像正常运行，但是文件不会完全保存下来，并且“修改日期”文件不会反映出更新的运行。我的补救措施是关闭excel并重新打开它，然后手动启动“ RunScripts2”宏，以使计时器和进程重新开始。我已经经历了整整一天都没有“休息”的日子，并且有一天经历了多次休息。但是，最近一次中断一天一次，我重新启动它，直到EOD为止都没问题。

我尝试失败的解决方案 我尝试将警报设置为True，但是即使保存过程也没有任何问题。就像它在保存一样，但并没有真正保存。真奇怪我已经对此进行了大量研究，但没有找到任何解决方案。我希望这里有人遇到类似的情况。

在此先感谢您的帮助！

下面的更新代码

似乎到目前为止已经可以使用...我还能提高效率吗？非常感谢。

scripts2 NEW.vbs:

Option Explicit
ExcelMacroExample
Sub ExcelMacroExample() 

Dim xlApp
Dim CopyFrom

Set xlApp = GetObject(,"Excel.Application") 
xlApp.Visible = True

Set CopyFrom = xlApp.Workbooks.Open("\\xxxx\xxxx\xxxx\Model NEW.xlsm",3,True) 

Dim dteWait
dteWait = DateAdd("s", 5, Now())
Do Until (Now() > dteWait)
Loop

CopyFrom.WorkSheets("Data").Activate()
CopyFrom.Worksheets("Data").Range("B1:K275").Copy
CopyFrom.Worksheets("Data").Range("B1").PasteSpecial -4163, -4142, False, False
xlApp.CutCopyMode = False

xlApp.DisplayAlerts = False
CopyFrom.SaveAs "\\xxxx\xxxx\xxxx\Model NEW.xlsx", 51
xlApp.DisplayAlerts = True

CopyFrom.Close False

Dim xlAppp
Set xlAppp = GetObject(,"Excel.Application") 
xlAppp.Visible = True

End Sub

ActiveWorkbook.SaveAs随机显示保存加载弹出窗口，但实际上不保存

0 个答案: