VBA выскакивает с предупреждающим знаком в окне сообщения, но без сообщения об ошибке - PullRequest
0 голосов
/ 24 апреля 2020

Я пытаюсь открыть все файлы в указанной папке один за другим, установить автоматическое вычисление c, чтобы извлечь данные из нашей системы отчетов (IBM Cognos / TM1), сохранить файл, закрыть его и перейти к следующей файл.

Мой макрос продолжает глючить. Там нет описания ошибки, просто пустое поле с предупреждением. Я думал, что это может быть проблема со скоростью, поскольку Citrix несколько медленный. Я добавил doevents, breaks et c. чтобы убедиться, что файлы полностью рассчитаны и сохранены. Обычно это происходит после сохранения или перед открытием следующего файла. В файлах много вкладок, и для их вычисления требуется некоторое время.

Когда я запускаю макрос пошагово, он работает как чудо.

Я надеюсь, что один из вас, гении, может помочь я решаю это.

Спасибо за ваше время в любом случае.

Ниже мой код:

Sub RefreshAllFilesInFolder()

Dim wb As Workbook
Dim filePath, month, year, fileName, fileType As String
Dim a, b As Date
Dim folder As Object
Dim i As Integer
Dim n As Integer
Dim LastRow As Integer

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Clear the list of processed files
LastRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row
ThisWorkbook.Sheets(1).Range("F6:F" & LastRow + 1).Clear

'Retrieve Target Folder Path from the sheet
filePath = ThisWorkbook.Sheets(1).Cells(9, 2) & "\"

'Filters Excel files
fileType = "*.xls*"

'Obtain the filename of the excel file in the folder
fileName = Dir(filePath & fileType)

'Obtain the parameters
month = ThisWorkbook.Sheets(1).Cells(7, 2)
year = "Year " & ThisWorkbook.Sheets(1).Cells(6, 2)

i = 4

a = Now()

'Loop through each Excel file in folder
  Do While fileName <> "" 
    'Disable popups
    Application.DisplayAlerts = False

    'Check if file is open already. It will be read-only
        If IsFileOpen(filePath & fileName) = True Then
              MsgBox fileName & " is already open. Please close the file and re-run the macro!"
              Exit Sub
        End If

    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(fileName:=filePath & fileName)

    'Ensure Workbook has opened before moving on to next line of code.
    DoEvents

    'Write the filename in the statusbar
    Application.StatusBar = "Updating file " & fileName

   'When workbook is opened paste the parameters in the file
    ActiveWorkbook.Sheets("Cockpit").Cells(11, 3) = month
    ActiveWorkbook.Sheets("Cockpit").Cells(15, 3) = month
    ActiveWorkbook.Sheets("Cockpit").Cells(2, 4) = year

    'Set calculation to automatic and force Excel to finish calculations before continuing
    Application.Calculation = xlCalculationAutomatic

        'If calculation goes wrong, exit the sub and reset application settings. Loop until calculation is finished
        On Error GoTo ErrorHandler
            n = 0
            Do Until Application.CalculationState = xlDone
           DoEvents
            n = n + 1
        Loop

    'If the user is not connected to TM1 the field Project will be empty after calculation. Then exit the macro
    If ActiveWorkbook.Sheets("Cockpit").Cells(4, 3) = "" Then
        MsgBox "You are not connected to TM1. Please connect and restart the macro!"
            Application.DisplayAlerts = True
            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = True
            Application.StatusBar = "Ready"
            Application.StatusBar = False
        Exit Sub
    End If

      'Add the filename to the list of completed files
      ThisWorkbook.Sheets(1).Cells(i + 2, 6) = fileName
      ThisWorkbook.Sheets(1).Activate
      ThisWorkbook.Sheets(1).Cells(i + 2, 6).Select
                With Selection.Font.ThemeColor = xlThemeColorDark1
                     Selection.Font.Color = RGB(255, 255, 255)
                     Selection.Interior.Color = 6299648
                     Selection.Interior.Pattern = xlSolid
                End With

      i = i + 1

    'Save and Close Workbook disable popup alerts (will choose the default button)

On Error GoTo ErrorHandler

    'Set calculation to manual before saving the file
        Application.Calculation = xlCalculationManual

        Application.CalculateBeforeSave = False

    'Save the file and wait for 1 min before continuing to ensure saving is completed
        wb.Save
         Application.Wait (Now + TimeValue("0:02:00"))

    'Close the file and wait for 30 secs before continuing to ensure file is closed
        wb.Close
        Application.Wait (Now + TimeValue("0:01:00"))
        Set wb = Nothing
        DoEvents
    'If a error message shows up after the file has been saved, continue to the next file
    On Error Resume Next

    'Get next file name and loop to the next file
      fileName = Dir

  Loop

'Message Box when tasks are completed
b = Now()

  MsgBox "UPDATE COMPLETE! It took " & Format(b - a, "hh:mm:ss")

  'Reset Macro Optimization Settings
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True
    Application.StatusBar = False
Exit Sub

ErrorHandler:
  'Reset Macro Optimization Settings
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True
    Application.StatusBar = "Ready"
    Application.StatusBar = False
MsgBox "There was an error in " & fileName & ". Please re-run the macro for this and the remaining files!"
End Sub

Error pop-up

...