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

dmj120

Active Member
Joined
Jan 5, 2010
Messages
308
Office Version
  1. 365
  2. 2019
  3. 2010
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.
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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.
 
Upvote 0
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.
 
Upvote 0
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.
VBA Code:
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.
 
Upvote 0
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

VBA Code:
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.......
VBA Code:
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
 
Upvote 0
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:
VBA Code:
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
 
Upvote 0
Solution
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. ????
 
Upvote 0
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:
VBA Code:
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:
VBA Code:
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!
 
Upvote 0
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:
VBA Code:
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:
VBA Code:
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!
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,333
Members
452,636
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top