I am trying to figure out how to avoid the multiple msgboxes which appear when I run my code:
Public Function IsItGood(aWord As Variant) As Boolean
Dim s As String
s = "|"
tmp = s & aWord & s
patern = ""
For i = 1 To 100
patern = patern & s & i
Next i
For i = 1 To 10
patern = patern & s & "C" & i
Next i
patern = patern & s & "merge|complete framed|width|border left|border right" & s
If InStr(1, patern, tmp) > 0 Then
IsItGood = True
Else
IsItGood = False
End If
End Function
Above is the function which is used in the below worksheet_change:
Sub Worksheet_Change(ByVal Target As Range)
Dim BigS As String
Dim arr As Variant
Dim a As Variant
If Intersect(Range("G3:G19"), Target) Is Nothing Then Exit Sub
arr = Split(Target, " ")
If IsItGood(a) Then
MsgBox (" In row" + Target.Address(0, 0)) & vbCrLf & a & vbCrLf + "are ok"
Else
MsgBox Target.Address(0, 0) & vbCrLf & a & vbCrLf & "has bad stuff"
Application.Undo
End If
End Sub
The first "for" loops the 100 integers and the second from C1 to C10 and the msgbox is repeated for each splitted string.Is there a way to prevent the multiple msgboxes so only one msgbox to appear at a time. And also an "out of stack space" error appears because of the recursion.
Set at the beginning: Application.EnableEvents = False and set it to True at the end. Recursion occurs, because you are calling macro on change event of workbook, which also generates this event, thus the method is calling itself, thus recursion.
Related
My Macro is failing w/ seemingly no explanation. I'm thinking it could be a syntactical issue.
It is designed to hide/show certain rows based on a certain cell's (FacilityChoice) value. The value is input via Data Validation List.
It will work for a while , but sometimes the Debugger highlights one of my first two lines. I have been able to fix this simply by deleting and replacing the final character in each line.
Other times the Macro simply does not work & the debugger offers no feedback.
As described above, the failures I have observed fall into two categories:
an issue with Sub definition or the initial if not statement
an issue where no feedback is offered by the debugger
In scenario 1, I was able to fix the problem simply by deleting/rekeying the final character in the line.
I have been unable to successfully address scenario 2.
Please see code below:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Range("FacilityChoice"), Range(Target.Address)) Is Nothing Then
'Gen Office Scenario
If ActiveWorkbook.Sheets("SNA Tool").Range("FacilityChoice").Value = ActiveWorkbook.Sheets("References").Range("E2") Then
ActiveSheet.Rows(17 & ":" & 23).EntireRow.Hidden = False
ActiveSheet.Rows(25).EntireRow.Hidden = False
ActiveSheet.Rows(29 & ":" & 30).EntireRow.Hidden = False
ActiveSheet.Rows(37 & ":" & 39).EntireRow.Hidden = False
ActiveSheet.Rows(43 & ":" & 45).EntireRow.Hidden = False
'POP Scenario
ElseIf ActiveWorkbook.Sheets("SNA Tool").Range("FacilityChoice").Value = ActiveWorkbook.Sheets("References").Range("E3") Then
ActiveSheet.Rows(17 & ":" & 23).EntireRow.Hidden = True
ActiveSheet.Rows(25).EntireRow.Hidden = True
ActiveSheet.Rows(29 & ":" & 30).EntireRow.Hidden = True
ActiveSheet.Rows(37 & ":" & 39).EntireRow.Hidden = True
ActiveSheet.Rows(43 & ":" & 45).EntireRow.Hidden = True
'Warehouse Scenario
ElseIf ActiveWorkbook.Sheets("SNA Tool").Range("FacilityChoice").Value = ActiveWorkbook.Sheets("References").Range("E4") Then
ActiveSheet.Rows(17 & ":" & 23).EntireRow.Hidden = True
ActiveSheet.Rows(25).EntireRow.Hidden = True
ActiveSheet.Rows(29 & ":" & 30).EntireRow.Hidden = True
ActiveSheet.Rows(37 & ":" & 39).EntireRow.Hidden = True
ActiveSheet.Rows(43 & ":" & 45).EntireRow.Hidden = True
'Rapid Scenario
ElseIf ActiveWorkbook.Sheets("SNA Tool").Range("FacilityChoice").Value = ActiveWorkbook.Sheets("References").Range("E5") Then
ActiveSheet.Rows(17 & ":" & 23).EntireRow.Hidden = True
ActiveSheet.Rows(25).EntireRow.Hidden = True
ActiveSheet.Rows(29 & ":" & 30).EntireRow.Hidden = True
ActiveSheet.Rows(37 & ":" & 39).EntireRow.Hidden = True
ActiveSheet.Rows(43 & ":" & 45).EntireRow.Hidden = True
End If
End If
End Sub
You can use Select Case and a little re-arrangement to simplify your code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsRef As Worksheet, bHide As Boolean
If Application.Intersect(Me.Range("FacilityChoice"), Target) Is Nothing Then Exit Sub 'no action
Set wsRef = ThisWorkbook.Worksheets("References")
Select Case Me.Range("FacilityChoice").Value
Case wsRef.Range("E2").Value
bHide = False
Case wsRef.Range("E3").Value, wsRef.Range("E4").Value, wsRef.Range("E5").Value
bHide = True
Case Else
Exit Sub 'no action...
End Select
'set row visibility
Me.Range("A17:A23,A25,A29:A30,A37:A39,A43:A45").EntireRow.Hidden = bHide
End Sub
Note in a worksheet event handler you can use Me to refer to the worksheet: it's safer than using ActiveSheet
I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called ►spill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3
I have a worksheet (sheet1) which contains a cell A1 with formula ='sheet2'!D10. I would like to run a macro each time cell A1 in sheet1 changes (as a result of a change in D10 in sheet2). sheet2 is streaming financial data.
Because it is a change in value, Worksheet_Change does not trigger an event. I also can't seem to find a solution with Worksheet_Calculate.
In my research, the closest solution I could find was offered here, but I have not been able to successfully implement it.
You are going to have to use Worksheet_Calculate. It's unclear on whether the 'streaming' will trigger a Worksheet_Calculate in Sheet2 but the linked cell in Sheet1 will definitely trigger a Worksheet_Calculate in that worksheet's private code sheet providing you have calculation set to automatic.
You need a variable that will hold previous values of Sheet1!A1 that can be compared to the current value of Sheet1!A1. Some prefer to use a public var declared in a public module's declaration area; I prefer to use a static var within Sheet1's Worksheet_Calculate itself.
From Microsoft Docs,
Normally, a local variable in a procedure ceases to exist as soon as the procedure stops. A static variable continues to exist and retains its most recent value. The next time your code calls the procedure, the variable is not reinitialized, and it still holds the latest value that you assigned to it. A static variable continues to exist for the lifetime of the class or module that it is defined in.
The first issue is seeding the static variable for its first use. A variant-type variable that has never been given a value report True when tested with IsEmpty so when the workbook is first opened, the first calculation cycle will simply record the value of Sheet1!A1 into the static var. Any future calculation cycle will compare the value in Sheet1!A1 to the value held in the static var and if they are different, the external sub procedure ('... run a macro ...' according to your question's narrative) will be run and the new value of Sheet1!A1 will be stored in the static var. In this way, any change in the value returned by the formula in Sheet1!A1 will force a calculation cycle, hence the worksheet's Worksheet_Calculate event sub procedure which will in turn run your external sub procedure.
In Sheet1's private code sheet
Option Explicit
Private Sub Worksheet_Calculate()
Static s2d10 As Variant
If IsEmpty(s2d10) Then
'load static var with expected value
s2d10 = Cells(1, "A").Value2
ElseIf s2d10 <> Cells(1, "A").Value2 Then
'run sub procedure here
'... run a macro ...'
'load A1's current value into the static var
s2d10 = Cells(1, "A").Value2
End If
End Sub
Selection_Change & Change
I went into a different direction and got lost. I think there might be some useful stuff in here, so here's the code anyway. It could be working in most conditions, just lose the 'str1' lines.
The 'str1' lines are for debugging purposes and show the behavior of the cells at different conditions.
Not sure if the sub ChangeD10 is emulating your conditions.
Throwing in the towel, but would appreciate any pinpointing of errors in the code.
Option Explicit
Private TargetValue As Variant
Private TargetAddress As String
Private Sub Worksheet_Change(ByVal Target As Range)
'The Playground
Const cStrWs1 As String = "Sheet1"
Const cStrWs2 As String = "Sheet2"
Const cStrCell1 As String = "A1"
Const cStrCell2 As String = "D10"
'Other Variables
Dim oWs1 As Worksheet
Dim oWs2 As Worksheet
Dim oRng As Range
Dim varA1_Before As Variant
Dim varA1_Now As Variant
'Debug
Const r1 As String = vbCr
Dim str1 As String
'Initialize
Set oWs1 = ThisWorkbook.Worksheets(cStrWs1)
Set oWs2 = ThisWorkbook.Worksheets(cStrWs2)
Set oRng = oWs2.Range(cStrCell2)
varA1_Before = oWs1.Range(cStrCell1).Value
str1 = "Worksheet_Change"
'Play
If Target.Address = oRng.Address Then
If Target.Value <> TargetValue Then
varA1_Now = oWs2.Range(cStrCell2).Value
oWs1.Range(cStrCell1).Value = varA1_Now
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 & "' changed " _
& "(Target.Value <> TargetValue)" & r1 & Space(2) _
& "Before: TargetValue (" & TargetAddress & ") = '" _
& TargetValue & "'," & r1 _
& " varA1_Before (" & Range(cStrCell1).Address _
& ") = " & varA1_Before & "'," & r1 & Space(2) _
& "Now: Target.Value (" & Target.Address & ") = '" _
& Target.Value & "'," & r1 _
& " varA1_Now (" & Range(cStrCell1).Address _
& ") = " & varA1_Now & "'."
Else
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 _
& "' didn't change. TargetValue = '" & TargetValue _
& "' and Target.Value = '" & Target.Value & "'."
End If
Else
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 _
& "' not changed. The Target.Address is '" _
& Target.Address & "', TargetValue is '" & TargetValue _
& "' and Target.Value is '" & Target.Value & "'."
End If
Debug.Print str1
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const r1 As String = vbCr
Dim str1 As String
str1 = "Worksheet_SelectionChange"
If Target.Cells.Count = 1 Then
str1 = str1 & r1 & Space(1) & "Cell '" & Target.Address _
& "' selected " & r1 & Space(2) _
& "Before: TargetValue (" & TargetAddress & ") = '" _
& TargetValue & "'," & r1 & Space(2) _
& "Now: Target.Value (" & Target.Address & ") = '" _
& Target.Value & "'."
TargetValue = Target.Value
TargetAddress = Target.Address
Else
str1 = str1 & r1 & Space(1) & "Multiple cells in range '" _
& Target.Address & "'."
End If
Debug.Print str1
End Sub
Sub ChangeD10()
ThisWorkbook.Worksheets("Sheet2").Cells(10, 4) = 22
End Sub
New to all this but appreciate any help I can get.
Problem: I have a duty roster with initials and sometimes I want to highlight a specific person to see his/her schedule. The highlight consists of changing the font color and making it bold but I'd also like the cell color to change as well, to lets say light green. I do know that I can use the Search/Replace feature but I'd like a macro for this.
So far, I've managed to piece together an input box and I can change the font color and add 'bold' to the font (and other changes) but I haven't solved changing the cell color.
This is what I have so far:
Sub FindAndBold()
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="Skriv in dina initialer", _
Title:="Dina initialer")
If sFind = "" Then
MsgBox "Du skrev inget"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
.Characters(iFind, iLen).Font.Color = RGB(255, 0, 0)
.Characters(iFind, iLen).Font.ColorIndex = 4
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "Fanns inget" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "att markera"
ElseIf lCount = 1 Then
MsgBox "Det fanns en" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "markerades"
Else
MsgBox lCount & " hittade" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "och markerades"
End If
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
Any help would be greatly appreciated!
(The text in the prompt and response is in Swedish)
You can also do this using conditional formatting, no need for VBS.
Using a conditional format formula you can enter something like this: =AND(ISNUMBER(SEARCH($G$1;A2));$G$1<>"") - in this case field G1 would be the field used for searching (read:highlighting) all the fields containing this condition.
If you desire a VBS we can improve and include a filter for all lines matching your search:
Sub searchfilter()
Range("A11:M10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("A2:M13"), Unique:=False
End Sub
And to clear:
Sub clearfilter()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Assign both macros to a button.
Sample image where i combined both (filter was done on C15 in this case):
And sample with hidden fields shown:
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
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
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.