VBA Excel: зависание при добавлении строки автосохранения - PullRequest
Новая
       9

VBA Excel: зависание при добавлении строки автосохранения

0 голосов
/ 31 августа 2018

У меня есть код, который проверяет событие «перед сохранением», заполняет ли пользователь обязательные ячейки. Когда я попытался добавить дополнительную строку для присвоения файла автоматическому имени, код зависает. Все же создайте файл. Ниже вы можете найти мой код, большая часть кода просто проверяет ячейки, но я не уверен в причине ошибки, поэтому я добавляю все это на случай, если что-то пропустил. 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim message As String
Dim say As Long

say = Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("C:C"))

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("D:D")) <> say Then
   message = Range("D1").Value & vbCrLf
End If
If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("F:F")) <> say Then
   message = message & Range("F1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("G:G")) <> say Then
   message = message & Range("G1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("H:H")) <> say Then
   message = message & Range("H1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("I:I")) <> say Then
   message = message & Range("I1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("J:J")) <> say Then
   message = message & Range("J1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("K:K")) <> say Then
   message = message & Range("K1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("M:M")) <> say Then
   message = message & Range("M1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("N:N")) <> say Then
   message = message & Range("N1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("Q:Q")) <> say Then
   message = message & Range("Q1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("R:R")) <> say Then
   message = message & Range("R1").Value & vbCrLf
End If

If Application.WorksheetFunction.CountA(Worksheets("ACC REQ").Range("AU:AU")) <> say Then
   message = message & Range("AU1").Value & vbCrLf
End If

If message <> "" Then
   MsgBox "" & message & vbCrLf & "Can’t Save with Empty Cells!!"

Cancel = True
End If


ThisFile = Format(Now(), "yyyy-mm-dd") & "__" & "ACC__" & Range("H2").Value & "__" & "CR"
ActiveWorkbook.SaveAs Filename:=ThisFile & ".xlsx"

End Sub

привет

Ответы [ 2 ]

0 голосов
/ 31 августа 2018

Это заняло у меня минуту, но я знаю, в чем проблема! У вас есть событие, которое называется BeforSave, в котором вы сохраняете. Это означает, что у вас есть Событие внутри себя. Это вызывает бесконечный цикл.

Сделайте это: 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
Dim message As String
Dim say As Long
Dim ThisFile As String
Dim Path As String

'.. Check stuff ..


Path = "C:\YourPath\YourFolder\"
ThisFile = Format(Now(), "yyyy-mm-dd") & "__" & "ACC__" & Range("H2").Value & "__" & "CR"
ThisWorkbook.SaveAs Filename:=ThisFile & ".xlsm"

Application.EnableEvents = True
Cancel = True

End Sub

Это должно решить ваши проблемы, так как отключает события на время фактического сохранения. Убедитесь, что у вас есть Application.EnableEvents=True, иначе он вообще не сработает.

0 голосов
/ 31 августа 2018

Решение:

Поместите Cancel=True в конце процедуры, чтобы предотвратить зависание Excel из-за бесконечного цикла.

Когда вы сохраняете файл, событие Workbook_BeforeSave запускается * до того, как Excel сохранит файл **, как обычно.

Это можно предотвратить с помощью Cancel=True, что необходимо в этом случае, так как вы хотите SaveAs сделать это самостоятельно.

Без Cancel=True ваш SaveAs снова вызывает событие Workbook_BeforeSave, где вы снова SaveAs, который снова запускает событие Workbook_BeforeSave .... и т.д ....

Альтернатива (более сжатая):

Ваш код должен работать с изменениями, приведенными выше, но ниже представлен способ дальнейшего сжатия кода путем удаления повторений. (См. Также, как создать Минимальный, Полный и Проверяемый пример .)

Уменьшение размера происходит из-за использования With..End With и циклического перемещения по статическому массиву, чтобы избежать повторения того же кода. 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim msg As String, say As Long, ws As Worksheet, col
  Set ws = Worksheets("ACC REQ")
  With Application.WorksheetFunction
    say = .CountA(ws.Columns("C"))
    For Each col In Array("D","F","G","H","I","J","K","M","N","Q","R","AU")
      If .CountA(ws.Columns(col))<>say Then msg=msg & Range(col & "1") & vbCrLf
    Next col
    Cancel = True  'we don't need Excel to save it
  End With
  If msg <> "" Then
      MsgBox msg, , "Can't Save with Empty Cells!": Exit Sub
  End If
  ActiveWorkbook.SaveAs Format(Now(), "yyyy-mm-dd") _
              & "__ACC__" & Range("H2") & "__CR.xlsx"
End Sub
...