Expanding a working code in Workbook_BeforeSave to more sheets with small alterations? VBA

JBM91

New Member
Joined
Oct 22, 2019
Messages
9
Hi experts!

I'm fairly new to VBA to say the least, but I have managed to piece together a code that works and does exactly what I want it to. The code looks as follows:

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



Dim Rng1 As Range
Dim Rng2 As Range
Dim Prompt As String
Dim Cell As Range
Dim AllowSave As Boolean

AllowClose = True
Set Rng1 = Sheets("example").Range("A6, M6, Y6, A9, M9, Y9, AF9, A12")
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:" & vbCrLf & vbCrLf

For Each Cell In Rng1
If Application.Sheets("example").Range("C42").Value <> "" And Cell.Value = vbNullString Or Cell.Value = "0" Then
Prompt = Prompt & Cell.Address(False, False) & vbCrLf
AllowClose = False
If Rng2 Is Nothing Then
Set Rng2 = Cell
Else
Set Rng2 = Union(Rng2, Cell)
End If
End If
Next

If AllowClose Then
Else
MsgBox Prompt, vbCritical, "Data entry missing"
Cancel = True
Rng2.Select
End If


End Sub


The thing is, as per defined in the code, this will only apply to the specific sheet "example1". What I essentially would like, is to also have the "same code", with varying alterations to the:

Set Rng1 = Sheets("Dekanter").Range("A6, M6, Y6, A9, M9, Y9, AF9, A12")

and

If Application.Sheets("Dekanter").Range("C42").Value <> "" And Cell.Value = vbNullString Or Cell.Value = "0"


.. applied to- and working on other sheets, say "example2", "example3" etc., with each sheet only being governed by its own code and independent from the other - if that makes sense(?)

(As of right now, this code is placed in "ThisWorkbook")

However, I'm not at all sure on how to do so, and as such, any help or tips from the heavies would be greatly appreciated!

Best regards,

Jannick
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,891
Office Version
2007
Platform
Windows
Hi @JBM91, welcome to the forum!


I made some changes to the code.
I removed the part of selecting the cells because they can be different sheets.



Try this

Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim Rng1 As Range, Prompt As String, Cell As Range, AllowClose As Boolean, sh As Worksheet
  '
  AllowClose = True
  Prompt = "Please check your data ensuring all required cells are complete." & vbCr & _
    "You will not be able to close or save the workbook until the form has been filled out " & _
    "completely." & vbCr & vbCr & "The following cells are incomplete:" & vbCr & vbCr
  '
  For Each sh In Sheets
    Select Case sh.Name
      Case "example1", "example2", "example3" 'Put here the names of the sheets to verify
        Set Rng1 = sh.Range("A6, M6, Y6, A9, M9, Y9, AF9, A12")
        For Each Cell In Rng1
          If sh.Range("C42").Value <> "" And Cell.Value = vbNullString Or Cell.Value = "0" Then
            Prompt = Prompt & Cell.Worksheet.Name & "-" & Cell.Address(False, False) & vbCr
            AllowClose = False
          End If
        Next
        Prompt = Prompt & vbCr
    End Select
  Next
  If AllowClose = False Then
    MsgBox Prompt, vbCritical, "Data entry missing"
    Cancel = True
  End If
End Sub
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,157
Office Version
2013
Platform
Windows
Hi,
If the ranges are the same for each sheet & the sheet is active when you perform the save or close action then you could just change this line

Code:
Set Rng1 = Sheets("Dekanter").Range("A6, M6, Y6, A9, M9, Y9, AF9, A12")
to this

Code:
Set Rng1 = ActiveSheet.Range("A6, M6, Y6, A9, M9, Y9, AF9, A12")
Dave
 

JBM91

New Member
Joined
Oct 22, 2019
Messages
9
Hi Dante,

Thanks for the swift reply!

The thing about the solution you posted is that Rng1 will then be the same for all sheets the code is applied to - "A6, M6, Y6, A9, M9, Y9, AF9, A12", respectively, which is unfortunately not the case - the same goes for the "If sh.Range("C42").Value <> "" And Cell.Value = vbNullString Or Cell.Value = "0" Then".

On sheet2 the rng1 might be A3, M3, Y3 and the sh.range for value reference might be C40.
On sheet3 it might be Z1, O1, U1, and the sh.range for value reference might be T50
.. and so on.

So I guess what I'm looking for is a way to take the layout and structure of the code, and then apply it with appropriate and specific alterations for each sheet in my workbook.
I'm just not sure how to take the code from its current location in "ThisWorkbook" and then apply it to each individual sheet with appropriate changes.

Best regards,

Jannick
 

JBM91

New Member
Joined
Oct 22, 2019
Messages
9
Hi Dave,

Thanks for the quick reply!

I'm afraid that's not the case - On sheet2 the rng1 might be A3, M3, Y3 and the sh.range for value reference might be C40. On sheet3 it might be Z1, O1, U1, and the sh.range for value reference might be T50
.. and so on.

So I guess what I'm looking for is a way to take the layout and structure of the code, and then apply it with appropriate and specific alterations for each sheet in my workbook.
I'm just not sure how to take the code from its current location in "ThisWorkbook" and then apply it to each individual sheet with appropriate changes.

Best regards,

Jannick
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,157
Office Version
2013
Platform
Windows
No worries,
are you just wanting to check the active sheet for range completion before saving / closing? Or do you want to check ALL sheets in a list and their specified ranges?

Dave
 

JBM91

New Member
Joined
Oct 22, 2019
Messages
9
Preferably the latter, so that all sheets need to fulfill their respective criteria before the book can be closed.

//Jannick
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,157
Office Version
2013
Platform
Windows
Preferably the latter, so that all sheets need to fulfill their respective criteria before the book can be closed.

//Jannick

probably the solution maybe to change your sub to a Function


Place following update to your code in a STANDARD module


Rich (BB code):
Function DoNotAllow() As Boolean
    Dim Rng1 As Range, ReferenceCell As Range
    Dim Rng2 As Range, Cell As Range
    Dim i As Integer
    Dim Prompt As String
    Dim ws As Worksheet
    
    
    For Each ws In Worksheets(Array("Dekanter", "example"))
        i = i + 1
        
        Set Rng1 = ws.Range(Choose(i, "A6, M6, Y6, A9, M9, Y9, AF9, A12", _
                                      "A3, Y3, M3"))
        
        Set ReferenceCell = ws.Range(Choose(i, "C42", "C40"))


        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:" & vbCrLf & vbCrLf
        
        For Each Cell In Rng1
            If Len(ReferenceCell.Value) > 0 And Cell.Value = vbNullString Or Cell.Value = "0" Then
                Prompt = Prompt & Cell.Address(False, False) & vbCrLf
                If Rng2 Is Nothing Then
                    Set Rng2 = Cell
                Else
                    Set Rng2 = Union(Rng2, Cell)
                End If
            End If
        Next
        
        DoNotAllow = CBool(Not Rng2 Is Nothing)
        
        If DoNotAllow Then
            ws.Activate
            Rng2.Select
            MsgBox ws.Name & Chr(10) & Prompt, vbCritical, "Data entry missing"
            Exit Function
        End If
        
        Set Rng1 = Nothing
        Set Rng2 = Nothing
        Set ReferenceCell = Nothing
        Prompt = ""
    Next ws
End Function

Notes: 1 - Enter the ranges for Rng1 as shown in example shown in BLUE
2 - Enter the ranges for ReferenceCell Shown in ORANGE
3 - Enter the worksheet names Shown in RED

add following code to the THISWORKBOOK code page

Rich (BB code):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Cancel = DoNotAllow
End Sub




Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = DoNotAllow
End Sub

Not fully tested but hopefully will do what you want


Dave
 
Last edited:

JBM91

New Member
Joined
Oct 22, 2019
Messages
9
probably the solution maybe to change your sub to a Function


Place following update to your code in a STANDARD module


Rich (BB code):
Function DoNotAllow() As Boolean
    Dim Rng1 As Range, ReferenceCell As Range
    Dim Rng2 As Range, Cell As Range
    Dim i As Integer
    Dim Prompt As String
    Dim ws As Worksheet
    
    
    For Each ws In Worksheets(Array("Dekanter", "example"))
        i = i + 1
        
        Set Rng1 = ws.Range(Choose(i, "A6, M6, Y6, A9, M9, Y9, AF9, A12", _
                                      "A3, Y3, M3"))
        
        Set ReferenceCell = ws.Range(Choose(i, "C42", "C40"))


        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:" & vbCrLf & vbCrLf
        
        For Each Cell In Rng1
            If Len(ReferenceCell.Value) > 0 And Cell.Value = vbNullString Or Cell.Value = "0" Then
                Prompt = Prompt & Cell.Address(False, False) & vbCrLf
                If Rng2 Is Nothing Then
                    Set Rng2 = Cell
                Else
                    Set Rng2 = Union(Rng2, Cell)
                End If
            End If
        Next
        
        DoNotAllow = CBool(Not Rng2 Is Nothing)
        
        If DoNotAllow Then
            ws.Activate
            Rng2.Select
            MsgBox ws.Name & Chr(10) & Prompt, vbCritical, "Data entry missing"
            Exit Function
        End If
        
        Set Rng1 = Nothing
        Set Rng2 = Nothing
        Set ReferenceCell = Nothing
        Prompt = ""
    Next ws
End Function

Notes: 1 - Enter the ranges for Rng1 as shown in example shown in BLUE
2 - Enter the ranges for ReferenceCell Shown in ORANGE
3 - Enter the worksheet names Shown in RED

add following code to the THISWORKBOOK code page

Rich (BB code):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Cancel = DoNotAllow
End Sub




Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = DoNotAllow
End Sub

Not fully tested but hopefully will do what you want


Dave
"Thank you'ed", liked and upvoted.

That's exactly what I needed! I did a few tests and as far as I can tell it's working absolutely flawless.

Thank you so much for your help, much appreciated!

//Jannick
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,157
Office Version
2013
Platform
Windows
"Thank you'ed", liked and upvoted.

That's exactly what I needed! I did a few tests and as far as I can tell it's working absolutely flawless.

Thank you so much for your help, much appreciated!

//Jannick
Glad solution helps you

many thanks for your kind feedback


Dave
 

Forum statistics

Threads
1,078,393
Messages
5,339,926
Members
399,340
Latest member
JasonT903

Some videos you may like

This Week's Hot Topics

Top