PDA

View Full Version : Sleeper: More Form help needed



austenr
11-02-2004, 02:10 PM
Please see my post of 10-31-04 (http://www.vbaexpress.com/forum/showthread.php?t=1234) and the code that was suggested which works beautifuly. Now I have a new twist I could use some help on.

I would like to higlight the cells with no data in them and that is all with a message that says "You must have an entry for the highlighted cells."

Problem two. Is there a way to have this code work on all the sheets in the workbook. I have 4 sheets alltogether. In other words, Do not let the user save or exit without filling in all the empty cells on all sheets.

Again, thanks in advance for all your help. You guys rock!!!

CBrine
11-02-2004, 02:56 PM
austenr,
Can you post the code that you finally used? It's not entirely apparent what you finally ended up using. You also most likely modified it somewhat to get it work for you. Either way, it will be easier for us to determine what you need to do if you show us your code.

Cal

austenr
11-02-2004, 03:02 PM
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Rng1 As Range
Dim Rng2 As Range
Dim Prompt As String
Dim Cell As Range
Dim AllowClose As Boolean
Dim Desktop As Object
Dim MyPath As String
Dim MyName As String
Set Desktop = CreateObject("WScript.Shell")
MyPath = Desktop.SpecialFolders("Desktop")
MyName = "DailyInputs" & Format(Date, "ddmmyy") & ".xls"
AllowClose = True
Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,F11:F12,B20:B22,B26:B31,B38:B45,B49:B52")
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until all fields have an entry " & _
"The following cells are blank:" & vbCrLf & vbCrLf
For Each Cell In Rng1
If Cell.Value = vbNullString 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
ThisWorkbook.SaveAs (MyPath & "\" & MyName)
Else
MsgBox Prompt, vbCritical, "Incomplete Data"
Cancel = True
Rng2.Select
End If
End Sub

Zack Barresse
11-02-2004, 03:07 PM
I just saw your code. I was about to post this code, and I'll post it anyway, just because it's here ...


Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range, Rng6 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range
Set Rng1 = Sheets("Sheet1").Range("A2,B2,C2")
Set Rng3 = Sheets("Sheet2").Range("A2,B2,C2")
Set Rng4 = Sheets("Sheet3").Range("A2,B2,C2")
Set Rng5 = Sheets("Sheet4").Range("A2,B2,C2")
Set Rng6 = Sheets("Sheet5").Range("A2,B2,C2")
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
For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng5
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng6
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
Cancel = False
End If
End Sub


Now, this withstanding, which cells are on which sheet for you? Or can you adapt this?

austenr
11-02-2004, 03:14 PM
I believe that I can adapt this. Thanks so much!!!

austenr
11-02-2004, 03:36 PM
Perhaps I thought wrong. Cannot get it to compile or run. Here are my cells I want highlighted.

Group Profile: B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52

Eligibility Guidelines: F1,E5,E6,E9,E10,B7:B17,B21:B36

COBRA: J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17:E20

I only have 3 sheets

Thanks

Zack Barresse
11-02-2004, 03:45 PM
This works for me ...


Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range
Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17:E20")
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
For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
RngStr = RngStr & Cell.Parent.Name & "!" & _
Cell.Address(False, False) & vbCrLf
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
ThisWorkbook.Save
Cancel = False
End If
End Sub

Zack Barresse
11-02-2004, 04:36 PM
Also, to expand a little more, this will clean up your message box and have sheet headings (which I find more asthetic) ...



Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim shtName As String, Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range
Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17:E20")
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
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
ThisWorkbook.Save
Cancel = False
End If
End Sub

austenr
11-02-2004, 07:55 PM
I get a runtime error when I try to execute this code. Ihave attached the workbook I am using.

austenr
11-02-2004, 08:01 PM
Having trouble attaching the file. Anyway, the line where the runtime error subscript out of raqnge is the line:


Set Rng3 = Sheet ("Eligility Guidelines")

Refer to the last code on this thread.

Thanks

johnske
11-02-2004, 08:21 PM
Having trouble attaching the file. Anyway, the line where the runtime error subscript out of raqnge is the line:

Set Rng3 = Sheet ("Eligility Guidelines")

Refer to the last code on this thread.

Thanks
Check that all instances of "Eligibility" (including the sheet tab) are all spelt the same way....

John :bink:

austenr
11-02-2004, 08:36 PM
That did not work. Any other suggestions

johnske
11-02-2004, 08:44 PM
No, it's just that I tried out Zacks code earlier, got the same error, and then noted (but only after the 3rd check) I'd slipped an extra "il" into "Eligibility" for the sheets name - then I saw you'd also mis-spelt it above to "Eligility". It's a very easy word to mis-spell :bink:

johnske
11-02-2004, 08:46 PM
PS after fixing the spelling error it ran flawlessly :bink:

TonyJollans
11-03-2004, 03:32 AM
Rather than looping through cells, why not use special cells to find blanks?

Modifying Zack's latest code for this, I got ..


Private Sub AWorkbook_BeforeClose(Cancel As Boolean)
Dim shtName As String, Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range
Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17: E20")
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
Rng1.Interior.ColorIndex = 0
Rng3.Interior.ColorIndex = 0
Rng4.Interior.ColorIndex = 0
RngStr = ""
Dim RngBlanks As Range
On Error Resume Next
Set RngBlanks = Nothing
Set RngBlanks = Rng1.SpecialCells(xlCellTypeBlanks)
If Not RngBlanks Is Nothing Then
RngBlanks.Interior.ColorIndex = 6
RngStr = RngStr & RngBlanks.Parent.Name & vbCrLf & RngBlanks.Address(False, False) & vbCrLf & vbCrLf
End If
Set RngBlanks = Nothing
Set RngBlanks = Rng3.SpecialCells(xlCellTypeBlanks)
If Not RngBlanks Is Nothing Then
RngBlanks.Interior.ColorIndex = 6
RngStr = RngStr & RngBlanks.Parent.Name & vbCrLf & RngBlanks.Address(False, False) & vbCrLf & vbCrLf
End If
Set RngBlanks = Nothing
Set RngBlanks = Rng4.SpecialCells(xlCellTypeBlanks)
If Not RngBlanks Is Nothing Then
RngBlanks.Interior.ColorIndex = 6
RngStr = RngStr & RngBlanks.Parent.Name & vbCrLf & RngBlanks.Address(False, False) & vbCrLf & vbCrLf
End If
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
ThisWorkbook.Save
Cancel = False
End If
End Sub

Also, should it not really be in the BeforeSave event as well or instead of the BeforeClose?

austenr
11-03-2004, 08:21 AM
Here is the workbook I am running the code against. If you could look at this and let me know what was wrong. Thanks in advance.

Zack Barresse
11-03-2004, 09:05 AM
Hello Austen,

Change your sheet names to their VBA equivelants, e.g. Sheets("Group Profile") to Sheet1, etc. Works for me. There is one last issue and that has to do with your merged cells. It will fail to color the cells if they are merged. We can work around this but it gets rather difficult to add coding for this. If is often suggested that you get rid of merged cells whenever possible. I will wait to hear from you to proceed. If you can get rid of them, the first change should suffice; if you can't get rid of them, I'll (or whoever) will code around that.

austenr
11-03-2004, 11:07 AM
Works great!! One last question, when all fields are completed will they stay highlighted after the save or is there a way to make them default?

Thanks for hanging in there with me on this one!!

Zack Barresse
11-03-2004, 12:09 PM
Okay Austen,

I've made some adjustments. This is due in part to your checkboxes on sheet COBRA. They were createdfrom the Forms toolbar. I have re-created them from the Controls Toolbox toolbar (they are ActiveX controls, won't work on Macs), if this is a problem, let me know. The code is as follows ...


Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim shtName As String, Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String, CkbxT As Boolean, CkbxF As Boolean
Dim Cell As Range
Dim cBool1 As Range, cBool2 As Range, cBool3 As Range, cBool4 As Range
Set Rng1 = Sheet1.Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheet2.Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheet4.Range("J2,H4,H5,C4,C5,C9,C10:C13")
Set cBool1 = Sheet4.Range("B17:B20")
Set cBool2 = Sheet4.Range("B25:B28")
Set cBool3 = Sheet4.Range("E17:E20")
Set cBool4 = Sheet4.Range("J15")
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
Start = True
For Each Cell In Rng1
If Cell.Value = vbNullString Then
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
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
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
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
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
End If
Next
If RngStr <> "" Then RngStr = Left(RngStr, Len(RngStr) - 2)
CkbxT = False
CkbxF = False
For Each Cell In cBool1
Select Case Cell.Value
Case True
If Cell.Offset(, 1).Value = True Then
CkbxT = True
End If
Case False
If Cell.Offset(, 1).Value = False Then
CkbxF = True
End If
End Select
Next Cell
For Each Cell In cBool2
Select Case Cell.Value
Case True
If Cell.Offset(, 1).Value = True Then
CkbxT = True
End If
Case False
If Cell.Offset(, 1).Value = False Then
CkbxF = True
End If
End Select
Next Cell
For Each Cell In cBool3
Select Case Cell.Value
Case True
If Cell.Offset(, 1).Value = True Then
CkbxT = True
End If
Case False
If Cell.Offset(, 1).Value = False Then
CkbxF = True
End If
End Select
Next Cell
For Each Cell In cBool4
Select Case Cell.Value
Case True
If Cell.Offset(, 1).Value = True Then
CkbxT = True
End If
Case False
If Cell.Offset(, 1).Value = False Then
CkbxF = True
End If
End Select
Next Cell
If CkbxT = True Then
RngStr = RngStr & vbCrLf & "You have conflicting checkboxes, please check."
End If
If CkbxF = True Then
RngStr = RngStr & vbCrLf & "You have not checked all checkboxes, do so."
End If
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
ThisWorkbook.Save
Cancel = False
End If
End Sub

Now, with these controls it has been identified by Microsoft as a bug that when you use print preview they will all move to the left side of the screen. The KB article is here to read (http://support.microsoft.com/default.aspx?scid=kb;en-us;838910). You need to have Service Pack (SP) 3 for the workaround.

As far as the highlighted cells go, I would use Conditional Formatting on them. This would be easier imo, and far less troublesome than putting it in code.

File attached..

.. removed by Zack; see next post.

Zack Barresse
11-03-2004, 12:36 PM
Okay, here is an updated version with Conditional Formatting

...

austenr
11-03-2004, 01:36 PM
Nothing highlights. I am fine with the previous version, I can work around the conditional formatting issue. There are some things I don't understand. All the cells are not highlighted that should be but the weird thing is is that they are defined at the top of the program. I am attaching the zip file so as not to get confused.

Thanks for all your hard work and help.

Zack Barresse
11-03-2004, 02:40 PM
They aren't highlighted because there is problems when referring to a single cell in a set range when that cell is Merged. That is why I have unmerged all of your cells in my last post and gone with only the Conditional Formatting to highlight/unhighlight cells which require data input. Did you look at the second file I uploaded? There were two, I deleted the first one. The second one is all that remains as I didn't want to confuse anyone.