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

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
87
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>
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 

CalcSux78

Well-known Member
Joined
Oct 15, 2013
Messages
1,120
@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:

jmacleary

Well-known Member
Joined
Oct 5, 2015
Messages
711
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.
 

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
87
@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))"
 

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
87
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:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 

Forum statistics

Threads
1,077,621
Messages
5,335,285
Members
399,011
Latest member
rodmicpc

Some videos you may like

This Week's Hot Topics

Top