A msg box only sometimes alerts on earlier date entered

[dpaton05]

I have a table and the first column for a row is the date. If a date is entered that is earlier then today's date, a message box should appear and ask you if that is what you want. It is just to add an extra layer of protection against typos. If a new row is added then a date entered that is earlier than today, the message box will appear but if you open the worksheet and straight away enter a date without adding any new rows, the message box will not appear. What do I need to change so that the message box will appear regardless?

Thanks,
Dave


I think this is the part that needs to be changed:

Private Sub Worksheet_Change(ByVal Target As Range)
'Worksheets("Costing_tool").Unprotect
Dim ans As String
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Application.EnableEvents = False
    If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
        If Target.Value < Date Then
            ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
        If ans = vbNo Then Target.Value = ""
        End If
    End If


    Application.EnableEvents = True
'Worksheets("Costing_tool").Protect
End Sub

 

[Michael M]

With the code you have posted, If a date is being entered anywhere in Col "A" the message should appear IF the date is older than today !!

 

[dpaton05]

If you select the delete all lines button it won't show the message box when an earlier date on the empty line is entered either.

Here is the delete Lines code:

Sub cmdDeleteAllQuoteLines()
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete

        End If
        'Clear the contents, but not delete the formulas
        For Each cell In tbl.ListRows(1).Range.Cells
            If Not cell.HasFormula Then
                cell.Value = ""
            End If
        Next
    End With
        With ThisWorkbook.Worksheets("NPSS_quote_sheet")
            .ListObjects("npss_quote").DataBodyRange.Columns(13).Value = 1 - 0.1 * ActiveSheet.chkIncrease.Value
            .Rows(11).Font.Bold = False
        End With
            
    'ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"
End Sub

Any help would be greatly appreciated.

 

[dpaton05]

Is there somewhere else I should put it so that it is running all the time as the code is only triggered at certain times, such as the worksheet being changed, but what about if the worksheet is opened and the date entered? The message box will not be entered here.

 

[dpaton05]

I had an idea. I put the code in its own procedure and I thought I could just call it from the other procedures that I was having the problems with it.

Sub cmdOlderToday()
    Dim ans As String
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Application.EnableEvents = False
    If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
        If Target.Value < Date Then
            ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
        If ans = vbNo Then Target.Value = ""
        End If
    End If
End Sub

But I tried that and I got the error message with this code Sub or function not defined and it highlighted the line

call cmdOlderToday

Within my procedure:

Private Sub cmdDeleteQuoteLines_Click()
ActiveSheet.Unprotect
    Call cmdDeleteAllQuoteLines
    Call cmdOlderToday
'ActiveSheet.Protect
End Sub

 

[Michael M]

but what about if the worksheet is opened and the date entered?

If you open the worksheet that has the code attached to it....it will fire every time column "A" is changed. ??

 

[dpaton05]

It does but if you select the button to delete all lines, it will not appear if entered in the first row after the deletion.

 

[Michael M]

That may be because this code has no bearing on the "costingTool" sheet.....which the worksheet event code applies to !
You may need to put the event code in quote sheet as well !

Sub cmdDeleteAllQuoteLines()
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete

        End If
        'Clear the contents, but not delete the formulas
        For Each cell In tbl.ListRows(1).Range.Cells
            If Not cell.HasFormula Then
                cell.Value = ""
            End If
        Next
    End With
        With ThisWorkbook.Worksheets("NPSS_quote_sheet")
            .ListObjects("npss_quote").DataBodyRange.Columns(13).Value = 1 - 0.1 * ActiveSheet.chkIncrease.Value
            .Rows(11).Font.Bold = False
        End With
            
    'ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"
End Sub

 

[Peter_SSs]

If you select the delete all lines button it won't show the message box when an earlier date on the empty line is entered either.

Here is the delete Lines code:

Sub cmdDeleteAllQuoteLines()
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        [COLOR="#FF0000"][B]If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete[/B][/COLOR]

        End If

In relation to this issue, your problem begins with the red lines above.
Since they are changing what is on the worksheet, the Worksheet_Change code is triggered.
In that procedure you have the following

    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Application.EnableEvents = False
    If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub

Because rows were deleted there is an intersection between Target and column A
So EnableEvents is set to False
Then you have this red bit which is True (because the rows are now all empty) so the Sub is exited with EnableEvents still set to False

Therefore, next time you enter something on the sheet, the Worksheet_Change (event) is not triggered.

 

[dpaton05]

Thanks for the reply Peter. Sorry, I didn't really follow with what I need to do to get it working. Could you let me know please?