Cancel saving if condition not met?

[ClimoC]

Hello,

was wondering if I can stop a user from saving the workbook if a condition fails?

Easiest condition would be

For each c in Range("M6:M1000")
    If c.interior.colorindex = 3 Then
         'Do not allow to save
    Else
         'Allow to save
    End If
Next

So in words - if any cell in the mentioned range is red, then do not allow a user to save the workbook (or saveas). Otherwise, proceed with the save command.

 

[GTO]

I believe the simplest answer would be similar to:
<font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br>    <br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_BeforeClose(Cancel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>)<br><SPAN style="color:#00007F">Dim</SPAN> c <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> c <SPAN style="color:#00007F">In</SPAN> Sheet1.Range("M6:M1000")<br>        <SPAN style="color:#00007F">If</SPAN> c.Interior.ColorIndex = 3 <SPAN style="color:#00007F">Then</SPAN><br>             Cancel = <SPAN style="color:#00007F">True</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

Please note that in the above, I used the sheet's codename. You could also use:

ThisWorkbook.Worksheets("Sheet1").

...in place of Sheet1.

However, it would probably be more important to address why the cell is red. Regardless of whether the cell color is a result of DV, or a previously run code (that is, the cell's interior.colorindex is actually changed), when dealing with larger ranges, it should be faster to flop the range into an array, and cycle (loop) thru the array, giving the same test taht resulted in the cell's interior changing.

Hope that makes sense,

Mark

 

[ClimoC]

Hi Mark - thanks for that.

That does make sense - thing is the reason the cell is red (or not) is the result of a worksheet_change macro that is doing something quite complicated.

 

[GTO]

If the test is really that complex, try adding 'Exit Sub' below the Cancel = True line.

I would test against:
<font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br>    <br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_BeforeSave(<SPAN style="color:#00007F">ByVal</SPAN> SaveAsUI <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>, Cancel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>)<br><SPAN style="color:#00007F">Dim</SPAN> aryMColVals <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> i As <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#007F00">'// As we are grabbing one column to assign to our dynamic array, the result    //</SPAN><br>    <SPAN style="color:#007F00">'// will be an array like: aryMColVals(1 to 995, 1 to 1), wherein there are 995 //</SPAN><br>    <SPAN style="color:#007F00">'// rowws and 1 col.                                                            //</SPAN><br>    aryMColVals = Sheet1.Range("M6:M1000").Value<br>    <br>    <SPAN style="color:#00007F">For</SPAN> i = <SPAN style="color:#00007F">LBound</SPAN>(aryMColVals, 1) <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(aryMColVals, 1)<br>        <SPAN style="color:#007F00">'// Substitute the test that made the cells red.  Herein, I simply test the //</SPAN><br>        <SPAN style="color:#007F00">'// val of ea cell.  If over 1000, then we cancel the save.                 //</SPAN><br>        <SPAN style="color:#00007F">If</SPAN> aryMColVals(i, 1) > 1000 <SPAN style="color:#00007F">Then</SPAN><br>            Cancel = <SPAN style="color:#00007F">True</SPAN><br>            <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

To test, simply add:
Dim Start as Single: Start = Timer
at the start of ea version of the sub, and:
Debug.Print Timer - Start
at the end.

You can use the Immediate window to see the results.

Hope that helps,

Mark

 

[ClimoC]

I'm havng some trouble with this... I already have a worksheet_change macro as I mentioned, and this one either just doesn't work, or doesn't work in conjunction with the worksheet_change macro.

The entire code for the sheet is below.

Private Sub Worksheet_change(ByVal Target As Range)
If Target.Column = 23 Then
If Target.Value <> "" Then
Dim Mystring As String
linelength = 35
rowcount = ActiveSheet.UsedRange.Rows.Count
For r = 6 To rowcount + 1
     k = 0
     i = 0
     linestart = 0
 Mystring = Range("W" & r)
 TextLength = Len(Mystring)
 
For i = 0 To 5
    If linestart > TextLength - 35 Then
      GoTo nextline
    Else:
    End If
  For k = 0 To 10
  
    If Mid(Mystring, linestart + linelength - k, 1) = " " Then
       linestart = linestart + linelength - k
       Mid(Mystring, linestart, 1) = Chr(10)
       linestart = linestart + 1
       
       GoTo Exitlabel
     Else:
    End If
  Next k
  
Exitlabel:
 k = 0
 Next i
 
nextline:
     
    Range("Y" & r).Value = Mystring
    If Range("Y" & r).Value <> "" Then
        Range("Z" & r).Select
        ActiveCell.FormulaR1C1 = _
        "=LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],CHAR(10),""""))+(LEN(RC[-1])>1)"
            If Range("Z" & r).Value > 4 Then
            Range("W" & r).Interior.ColorIndex = 3
            MsgBox "One of your Entry cells is too long. Please reduce its length"
        Else
        Range("W" & r).Interior.ColorIndex = 4
    End If
    Else
        'Do Nothing
    End If
Range("Y" & r).Font.ColorIndex = 55
Range("Z" & r).Font.ColorIndex = 55
Target.RowHeight = 12.75
    
Target.Select
Next r
Else
    Target.Interior.ColorIndex = 0
End If
End If
If Target.Column = 24 Then
    If Len(Target) > 190 Then
    Target.Interior.ColorIndex = 3
    MsgBox "One or more of your entry cells is too long. Please reduce it (Max Length : 190 Characters)"
    ElseIf Len(Target) <= 190 And Len(Target) <> 0 Then
    Target.Interior.ColorIndex = 4
    ElseIf Len(Target) = 0 Then
    Target.Interior.ColorIndex = 0
    End If
    
End If
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim c As Range
    
    For Each c In Range("W6:W1000")
        If c.Interior.ColorIndex = 3 Then
             Cancel = True
             MsgBox "Some kind of error message"
        End If
    Next
    For Each c In Range("X6:X1000")
        If c.Interior.ColorIndex = 3 Then
             Cancel = True
             MsgBox "Some kind of error message"
        End If
    Next
    
  
End Sub

ANy ideas?

 

[GTO]

My apologies, as I certainly should have pointed out that the Workbook_BeforeClose event (the entire sub/procedure that is) needs to be placed in the ThisWorkbook Module.

For reference, you will noet that worksheet events, such as Worksheet_Change, will always start with "Worksheet_", whereas workbook events such as Workbook_SheetChange will always start with "Workbook_".

Mark

 

[ClimoC]

Thanks GTO - that works.

One question though - The sheet that contains these macros comes from a workbook - and I don't want that workbook to have the beforesave macro.

I already use these two commands for exporting and importing macro modules:

With wbmain
ActiveWorkbook.VBProject.vbcomponents("module9").Export (DAddress & "Module9.bas")
End With

&

Dim DAddress As String
DAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator

With ActiveWorkbook
Application.VBE.ActiveVBProject.vbcomponents.Import (DAddress & "module9.bas")
End With

(they are in separate macros these two commands)

Can I export / import this beforesave macro to the new workbook via vba?

 

[ClimoC]

SOLVED!

Found and modified this macro. I don't really care why, or how, but when I first did this, writing line by line to the Event, the output was the macro was written backwards. Using this code, it is pasted in reverse (so last line is first line, first line is last line)

But heck, it works beautifully.

This macro is stuck in a module that is imported by the new worksheets. Each new worksheet then runs this macro to give itself an Event Macro (in this case, "Workbook_BeforeSave")

Sub CreateEventProcedure()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("ThisWorkbook")
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc("BeforeSave", "Workbook")
            LineNum = LineNum + 1
            
            
           
            .InsertLines LineNum + 1, "Next"
            .InsertLines LineNum + 1, "End If"
            .InsertLines LineNum + 1, "MsgBox " & DQUOTE & "You cannot save the Workbook whilst there is an error with your cells" & DQUOTE
            .InsertLines LineNum + 1, "Cancel = True"
            .InsertLines LineNum + 1, "If c.Interior.ColorIndex = 3 Then"
            .InsertLines LineNum + 1, "For Each c In Range(" & DQUOTE & "X6:X1000" & DQUOTE & ")"
            .InsertLines LineNum + 1, "Next"
            .InsertLines LineNum + 1, "End If"
            .InsertLines LineNum + 1, "MsgBox " & DQUOTE & "You cannot save the Workbook whilst there is an error with your cells" & DQUOTE
            .InsertLines LineNum + 1, "Cancel = True"
            .InsertLines LineNum + 1, "If c.Interior.ColorIndex = 3 Then"
            .InsertLines LineNum + 1, "For Each c In Range(" & DQUOTE & "W6:W1000" & DQUOTE & ")"
            .InsertLines LineNum + 1, "Dim c As Range"
            
         End With
End Sub