VBA - highlight if value is not evenly divisible by 365 (or fix the entry)

[dmj120]

I use a formula round('value'/365,2)*365 to round a dollar amount, which works great but with more people starting to participate, I'm wondering if I can add a script to either:
1. highlight a "non-rounded" value
2. or better yet - fix the entry; example: someone enters $350, the code would correct it to the nearest "rounded value" or $368.65.

 

[Joe4]

Based on the little information you provided, some things to consider:
1. Have a cell for data entry, then a lock cell with your formula that "adjusts" it. You can lock/protect that column so they do not overwrite it.
2. Just have them enter the amount, and have VBA code automatically adjust that amount.

If you need help with any of these ideas, please provide more information, such as where exactly they will be entering in this data (range references) and which option you would like to choose.

 

[dmj120]

2. Just have them enter the amount, and have VBA code automatically adjust that amount.

That would be AWESOME. the range of where the pricing is entered is G7:G7500. If the script would do similar to round('cell entry'/365,2)*365 I would be able to save soooooo many labor hours business-wide, and of course ensure proper pricing accuracy.

 

[Joe4]

Right-click on the sheet tab name at the bottom of the screen, select "View Code", and paste this VBA code in the VB Editor window that pops up.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
   
    Set rng = Intersect(Target, Range("G7:G7500"))
   
    If rng Is Nothing Then Exit Sub
   
    Application.EnableEvents = False
   
    For Each cell In rng
        cell.Value = Round(cell.Value / 365, 2) * 365
    Next cell
   
    Application.EnableEvents = True
       
End Sub

This should do what you want automatically, when an entry is made in cells G7:G7500.

 

[dmj120]

That looks perfect, but copy/paste to the date-entry script, gives error "compile error: ambiguous name detected: worksheet_change"

What am I doing wrong? Obviously, I can't simply copy/paste to the bottom of

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
'Timestamp Data
'   TeachExcel.com

Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range

'Your data table range
Set myTableRange = Range("E6:E11000")

'Check if the changed cell is in the data tabe or not.
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

'Stop events from running
Application.EnableEvents = False

'Column for the date/time
Set myDateTimeRange = Range("I" & Target.Row)
'Column for last updated date/time
Set myUpdatedRange = Range("J" & Target.Row)

'Determine if the input date/time should change
If myDateTimeRange.Value = "" Then

    myDateTimeRange.Value = Date

End If

'Update the updated date/time value
myUpdatedRange.Value = Now

'Turn events back on
Application.EnableEvents = True
End Sub

ie.......

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
'Timestamp Data
'   TeachExcel.com

Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range

'Your data table range
Set myTableRange = Range("E6:E11000")

'Check if the changed cell is in the data tabe or not.
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

'Stop events from running
Application.EnableEvents = False

'Column for the date/time
Set myDateTimeRange = Range("I" & Target.Row)
'Column for last updated date/time
Set myUpdatedRange = Range("J" & Target.Row)

'Determine if the input date/time should change
If myDateTimeRange.Value = "" Then

    myDateTimeRange.Value = Date

End If

'Update the updated date/time value
myUpdatedRange.Value = Now

'Turn events back on
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
   
    Set rng = Intersect(Target, Range("G7:G7500"))
   
    If rng Is Nothing Then Exit Sub
   
    Application.EnableEvents = False
   
    For Each cell In rng
        cell.Value = Round(cell.Value / 365, 2) * 365
    Next cell
   
    Application.EnableEvents = True
       
End Sub

 

[Joe4]

Ah, you didn't mention that you already have some automated code on this sheet.
You cannot have two procedures with the same name in the same module, and the automated event procedures MUST be named a certain way (you cannot change their name if you want them to work automatically).

So we will need to put them both in the same procedure, one under the other, but also slightly amend the lines of code that exit the procedures.
See if this works:

Private Sub Worksheet_Change(ByVal Target As Range)
'Timestamp Data
'   TeachExcel.com

'***CHECK 1*****

Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range

'Your data table range
Set myTableRange = Range("E6:E11000")

'Check if the changed cell is in the data tabe or not.
If Not Intersect(Target, myTableRange) Is Nothing Then

    'Stop events from running
    Application.EnableEvents = False

    'Column for the date/time
    Set myDateTimeRange = Range("I" & Target.Row)
    'Column for last updated date/time
    Set myUpdatedRange = Range("J" & Target.Row)

    'Determine if the input date/time should change
    If myDateTimeRange.Value = "" Then
        myDateTimeRange.Value = Date
    End If

    'Update the updated date/time value
    myUpdatedRange.Value = Now

    'Turn events back on
    Application.EnableEvents = True

End If

'***CHECK 2***
Dim rng As Range
Dim cell As Range
   
Set rng = Intersect(Target, Range("G7:G7500"))
   
If Not rng Is Nothing Then
    Application.EnableEvents = False
   
    For Each cell In rng
        cell.Value = Round(cell.Value / 365, 2) * 365
    Next cell
   
    Application.EnableEvents = True
End If

End Sub

 

[dmj120]

Ah, you didn't mention that you already have some automated code on this sheet.
You cannot have two procedures with the same name in the same module, and the automated event procedures MUST be named a certain way (you cannot change their name if you want them to work automatically).

So we will need to put them both in the same procedure, one under the other, but also slightly amend the lines of code that exit the procedures.
See if this works:

Works perfectly!!! Thank you so much for the help, and explanation. ????

 

[Joe4]

You are welcome!
Glad I was able to help.

Just note the one change we had to make:
Previously, your first code has this line in there:

If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

which basically said that if the updated cell is not in "myTableRange", to exit the sub.

However, that would no longer work, as it would bail out before doing our second check.
So instead of telling it when to "bail out", we are telling it when to process the first set of code by changing that line slightly, like this:

If Not Intersect(Target, myTableRange) Is Nothing Then

which is now checking to see if the updated cell IS in "myTableRange" using the old double-negative ("Not ... Is Nothing" means it is something!).

Hope that makes sense!

 

[dmj120]

You are welcome!
Glad I was able to help.

Just note the one change we had to make:
Previously, your first code has this line in there:

If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

which basically said that if the updated cell is not in "myTableRange", to exit the sub.

However, that would no longer work, as it would bail out before doing our second check.
So instead of telling it when to "bail out", we are telling it when to process the first set of code by changing that line slightly, like this:

If Not Intersect(Target, myTableRange) Is Nothing Then

which is now checking to see if the updated cell IS in "myTableRange" using the old double-negative ("Not ... Is Nothing" means it is something!).

Hope that makes sense!

Point taken, thanks again!!!!! VBA is still so foreign to me. Slowly trying to learn, so this really helps!