VBA Excel: Freeze when add Auto Save line - excel

Question

I have a code which checks "before save" event whether user fill mandatory cells.
When I tried to add additional line for give file to an automated name, code freezes. Yet create the file. Below you can find my code, most of the code is just checking the cells, but I'm not sure the reason of error, so I'm adding all of it in case there's something I missed.
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
regards

Answer 1

Solution:
Put Cancel=True at the end of the procedure to keep Excel from freezing due to an infinite loop.
When you save the file, the Workbook_BeforeSave event runs *before Excel saves the file** like it normally would.
This can be prevented with Cancel=True, which is necessary in this case since you want to SaveAs it yourself.
Without Cancel=True, your SaveAs is triggered the Workbook_BeforeSave event again, where you SaveAs again which triggers the Workbook_BeforeSave event again....etc....
Alternative (more compressed):
Your code should work with the change above, but below is a way to compress the code further by removing repetition. (See also, how to create a Minimal, Complete, and Verifiable example.)
The size reduction is because of the use of With..End With and looping through a static array to avoid repeating the same code.
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

Answer 2

This one took me a minute but I know what's the problem! You have an Event that is called BeforSave in which you save. Which means that you have the Event within it self. This causes an infinite loop.
Do this:
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
This should solve your problems as it disables the events for the duration of the actual saving. Make sure that you have the Application.EnableEvents=True otherwise it will not fire at all.