ActiveWorkbook.SaveAs случайным образом показывает всплывающее окно сохранения загрузки, но на самом деле не сохраняет - PullRequest
Новая
       14

ActiveWorkbook.SaveAs случайным образом показывает всплывающее окно сохранения загрузки, но на самом деле не сохраняет

0 голосов
/ 27 февраля 2019

У меня случайная проблема, с которой я сталкиваюсь примерно один или два раза в день по сценарию, который запускается каждые 2 минуты с 7:00 до 17:00 ежедневно, и я надеюсь, что кто-то здесь сможет определить, что может быть причиной.

Я постараюсь сохранить этот пост как можно более организованным и точным, поскольку в процессе используются 3 отдельных сценария.

Скрипт № 1 размещен в рабочей книге PERSONAL.XLSB и является таймером для начала процесса в 7:00 и повторения каждые 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

Script # 2 - это скрипт scripts2.VBS, который Script # 1 вызывает каждые 120 секунд.Это открывает книгу 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 размещен в книге Model.xlsm, которую вызывает сценарий № 2.Код ниже: 

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