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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
10,217
Office Version
2007
Platform
Windows
Hi Dante,
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.
In the original post you didn't mention that they could be different cells for each sheet.


But no problem, I attached the updated code, with another approach, in the end the result shows you the sheets and cells without data.

I also marked the place where you can put your data.

Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)
  Dim Rng1 As Range, rng2 As Range, Prompt As String, Cell As Range, AllowClose As Boolean, sh As Worksheet
  Dim shs As Variant, rgs As Variant, cls As Variant, h As Long
  '
  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
  '
[COLOR=#0000ff]  shs = Array("example1", "example2", "example3")  'sheets[/COLOR]
  [COLOR=#008000]rgs = Array("A6, M6, Y6, A9, M9, Y9, AF9, A12", "Z1, O1, U1", "D3, D5, D6") 'ranges[/COLOR]
[COLOR=#b22222]  cls = Array("C40", "C41", "C42") 'cells[/COLOR]


  For h = 0 To UBound(shs)
    Set sh = Sheets(shs(h))
    Set Rng1 = sh.Range(rgs(h))
    For Each Cell In Rng1
      If sh.Range(cls(h)).Value <> "" And Cell.Value = vbNullString Or Cell.Value = "0" Then
        Prompt = Prompt & Cell.Worksheet.Name & "-" & Cell.Address(False, False) & vbCr
        AllowClose = False
        If rng2 Is Nothing Then
          Set rng2 = Cell
        Else
          Set rng2 = Union(rng2, Cell)
        End If
      End If
    Next
    Prompt = Prompt & vbCr
    If AllowClose = False Then
      sh.Select
      rng2.Select
      MsgBox Prompt, vbCritical, "Data entry missing"
      Set rng2 = Nothing
      cancel = True
    End If
  Next
End Sub
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Watch MrExcel Video

Forum statistics

Threads
1,089,751
Messages
5,410,218
Members
403,304
Latest member
pajg

This Week's Hot Topics

Top