Code to change date to 1 years time by using a pro-word

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
107
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
Hello,

I would like some help with a bit of code.

What I have is some dates in cells H3:H. I would like toenter in the word "1Y" in the next cell I3:I and it will add 1 Yearto the date in H3 and apply it to cell I3.

Basically, I need to tract when people have done a test, andif they are due it in a years’ time. Now I plan on adding more than just “1y”and have “1w” (1 week), “2y” etc.
Thanks in advance.



G
H (Date of last test)
I (Date of next test)
Name1
16/07/19
1y (Once this has been inputted it will change to 16/07/20)
Name2
26/01/19


<tbody> </tbody>
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Try this:-
Place code in worksheet module.
Code runs when data altered in column "I".
Code:
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] nstr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
Application.EnableEvents = False
[COLOR="Navy"]If[/COLOR] Target.Column = 9 And Len(Target.Value) = 2 And IsDate(Target.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Left(Target.Value, 1) Like "[1-9]" And UCase(Right(Target.Value, 1)) = "W" Or UCase(Right(Target.Value, 1)) = "Y" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] UCase(Right(Target.Value, 1))
            [COLOR="Navy"]Case[/COLOR] "Y": Target.Value = DateAdd("yyyy", Left(Target.Value, 1), Target.Offset(, -1).Value)
            [COLOR="Navy"]Case[/COLOR] "W": Target.Value = DateAdd("ww", Left(Target.Value, 1), Target.Offset(, -1).Value)
        [COLOR="Navy"]End[/COLOR] Select
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
Application.EnableEvents = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
@MickG 's is more elegant. Here's another approach.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Targ As Range, cel As Range, dt As Date
Dim i&


Set Targ = Intersect(Range("I:I"), Target)
If Targ Is Nothing Then Exit Sub
For Each cel In Targ
    If cel.Column = 9 Then
        dt = cel.Offset(, -1)
        i = CLng(Left(cel.Value, Len(cel.Value) - 1))
        Select Case True
            Case InStr(1, cel.Value, "y", vbTextCompare) > 0
                cel = DateSerial(Year(dt) + i, Month(dt), Day(dt))
            Case InStr(1, cel.Value, "m", vbTextCompare) > 0
                cel = DateSerial(Year(dt), Month(dt) + i, Day(dt))
            Case InStr(1, cel.Value, "w", vbTextCompare) > 0
                cel = DateSerial(Year(dt), Month(dt), Day(dt) + (i * 7))
            Case InStr(1, cel.Value, "d", vbTextCompare) > 0
                cel = DateSerial(Year(dt), Month(dt), Day(dt) + i)
        End Select
    End If
Next cel
End Sub
 
Last edited:
Upvote 0
Both look good to me, but beware MickG's solution only works for single digits. e.g. 12W in the cell would only add 1 week.
 
Upvote 0
@CalcSux78

Awesome does the job. However after it completes the date. I get Runtime Error 13. Type Mismatch on "i = CLng(Left(cel.Value, Len(cel.Value) - 1))"
 
Upvote 0
Thank you @MickG

I am thinking of making this code better by having Day, Week, Month, Year. Would this be easier to change?
 
Last edited:
Upvote 0
Try this:-
Code:
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] nstr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Apha [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
 Apha = "YMWD"
Application.EnableEvents = False
[COLOR="Navy"]If[/COLOR] Target.Column = 9 And IsDate(Target.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
    Num = Left(Target.Value, Len(Target.Value) - 1)
    [COLOR="Navy"]If[/COLOR] IsNumeric(Num) And InStr(Apha, UCase(Right(Target.Value, 1))) > 0 [COLOR="Navy"]Then[/COLOR]
        
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] UCase(Right(Target.Value, 1))
            [COLOR="Navy"]Case[/COLOR] "Y": Target.Value = DateAdd("yyyy", Num, Target.Offset(, -1).Value)
            [COLOR="Navy"]Case[/COLOR] "M": Target.Value = DateAdd("m", Num, Target.Offset(, -1).Value)
            [COLOR="Navy"]Case[/COLOR] "W": Target.Value = DateAdd("WW", Num, Target.Offset(, -1).Value)
            [COLOR="Navy"]Case[/COLOR] "D": Target.Value = DateAdd("d", Num, Target.Offset(, -1).Value)
        [COLOR="Navy"]End[/COLOR] Select
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
Application.EnableEvents = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,113,998
Members
448,541
Latest member
iparraguirre89

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