Requiring Cells be Populated

[Phil Hageman]

There are four cells (merged cell ranges) I want users to
fill data into before leaving the worksheet (worksheet
name is "Scorecard"); G26:I26, AG26:AI26, G44:I44, and
AG44:AI44. I have an Auto_Open sub in place to open the
workbook on this "Scorecard" worksheet. These four cells
are weighting factors and the numbers, formatted percent,
must equal 100%. Also, there must be a number entry in
each of the four cells, even if it is zero. If the user
does not make an entry (blank cell) a message must come up
saying "Weight for cell *** is required." If they leave
multiple cells blank, the message would include those
cells as well. Users cannot leave the worksheet until all
four cells are populated.

What would the code be? Would I put the code in the
worksheet code object, or in Module 1?

 

[Bob Phillips]

Phil,

Are you ready for this?

This code goes in a normal code module, Module 1

'---------------------------------------------------------------------------
Public Function ValidScorecard() As Boolean
Dim sMsg As String

ValidScorecard = True

sMsg = sMsg & CheckRange("G26")

sMsg = sMsg & CheckRange("AG26")

sMsg = sMsg & CheckRange("G44")

sMsg = sMsg & CheckRange("AG44")

If Len(sMsg) > 0 Then
MsgBox sMsg
ValidScorecard = False
End If

End Function

Private Function CheckRange(cell As String)
Dim sMsg As String

With Worksheets("Scorecard")
If IsEmpty(.Range(cell)) Then
If .Range(cell).MergeArea.Address(False, False) <> cell Then
sMsg = "Weight for cell(s) " & _
.Range(cell).MergeArea.Address & _
" is required"
Else
sMsg = "Weight for cell " & _
.Range(cell).Address & _
" is required"
End If
CheckRange = sMsg & vbCrLf
End If
End With

End Function

'---------------------------------------------------------------------------


This following code goes in the Scorecard worksheet code module


'---------------------------------------------------------------------------
Private Sub Worksheet_Deactivate()

If Not ValidScorecard Then
Worksheets("Scorecard").Activate
End If
End Sub

'---------------------------------------------------------------------------

and finally, this goes in the ThisWorkbook code m odule


'---------------------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ActiveSheet.Name = "Scorecard" Then
If Not ValidScorecard Then
Cancel = True
Worksheets("Scorecard").Activate
End If
End If
End Sub

'---------------------------------------------------------------------------

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Phil Hageman]

Bob, Thanks for your reply - you're right, I am stepping
into the deep end. A request: I now have an additional
requirement that not only must the cells be populated, the
values entered must be greater than zero. Could you add
that feature into the code? Thanks, Phil

 

[Bob Phillips]

Phil,

Here it is. Just replace the CheckRange function with this code

Private Function CheckRange(cell As String)
Dim sMsg As String

With Worksheets("Scorecard")
If IsEmpty(.Range(cell)) Or .Range(cell).Value <= 0 Then
If .Range(cell).MergeArea.Address(False, False) <> cell Then
sMsg = "Weight for cell(s) " & _
.Range(cell).MergeArea.Address & _
" must be entered, and must be >0"
Else
sMsg = "Weight for cell " & _
.Range(cell).Address & _
" must be entered, and must be >0"
End If
CheckRange = sMsg & vbCrLf
End If
End With

End Function

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Phil Hageman]

Bob, I receive a compile error: Type Mismatch,

Public Function ValidScorecard() As Boolean
Dim sMsg As String
ValidScorecard = True
sMsg = sMsg & CheckRange("G26")
"G26" is highlighted

 

[Bob Phillips]

Phil,

Is this with the original or revised version? Although both should be okay,
I have tried them both with and without merged cells.

Want to send me the workbook to look at (do the usual with the email
address)

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[pjhageman]

Bob, need your e-mail address

*Phil,

Is this with the original or revised version? Although both should be
okay,
I have tried them both with and without merged cells.

Want to send me the workbook to look at (do the usual with the email
address)

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

message

 

[Bob Phillips]

bob . phillips @ tiscali . co . uk

remove the spaces

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)