Making several cells mandatory before letting to same and close

[Ardip]

Hello Excel experts,

I have been running around to find a solution for making several cells in different sheets mandatory to fill. The excel will be sent to third party to fill and send back, I would like to avoid email ping pong to ask for missing cells, below is the code I am using and it works fine. But but but, there is one issue and that is after I have added the code it doesn't even let myself to close the excel and asks me to fill all the cells. Is there any solution to add another code line in order to let me or others close the excel without saving?
The error if the cells left blank has only possibility to press "OK" button.

If you have alternative solution, I would appreciate if you share with me.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range

Dim Prompt As String, RngStr As String
Dim Cell As Range
'set your ranges here
'Rng1 is on sheet "Agency Details" and cells B5 through B14
'Cell F1, A range of F5 through F7 etc. you can change these to
'suit your needs.
Set Rng1 = Sheets("Agency Details").Range("B5:M5,B7:Q7,B9:P9,B11:P11,B13:I13,B15:I15,B17:N17,B20:I20,K20:M20,B21:I21,K21:M21,B22:I22,K22:M22,B23:I23,K23:M23,C29,C30,C31,C32,C33,A36,B44:K44,B45:K45,M44,M45,O44,O45,O46,B54,N54,Q54,B63,B64,B65,B66,B67,B68,B69,H63,H64,H65,H67,H68,H69,A72,A76")
Set Rng3 = Sheets("Agency Specialism").Range("B11:Q11")
Set Rng4 = Sheets("Agency Footprint").Range("B12:F12,H12:L12")
'message is returned if there are blank cells
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& vbCrLf & vbCrLf
Start = True
'highlights the blank cells
For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If

Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing

End Sub

 

[dmt32]

Hi,
welcome to forum

just add a line of code to exit the sub if it is you (admin ) using workbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range


'exit if admin user
   If Environ("USERNAME") = "Ardip" Then Exit Sub


'rest of code

enter your network username where shown in red

Dave

 

[Ardip]

Hi Dave, thanks a lot for your suggestion. If I am not mistaken this will only let me as the file admin to handle the excel with this permission right? If thats the case then it won’t be a perfect solution since the excel file will be used by a team and not only one person. The team members are task assigned based so its a large number of users. Any solution to that? Thanks

 

[dmt32]

Hi,
If you only want code to apply when users save the workbook then use the BeforeSave event

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'your code here
  
End Sub

Dave