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

[KyleJackMorrison]

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.

<tbody> [TD="width: 65, bgcolor: transparent"] G [/TD]
[TD="width: 78, bgcolor: transparent"] H (Date of last test) [/TD]
[TD="width: 200, bgcolor: transparent"] I (Date of next test) [/TD]
[TD="width: 65, bgcolor: transparent"] Name1 [/TD]
[TD="width: 78, bgcolor: transparent"] 16/07/19 [/TD]
[TD="width: 200, bgcolor: transparent"] 1y (Once this has been inputted it will change to 16/07/20) [/TD]
[TD="width: 65, bgcolor: transparent"] Name2 [/TD]
[TD="width: 78, bgcolor: transparent"] 26/01/19 [/TD]
[TD="width: 200, bgcolor: transparent"] [/TD]
</tbody>

 

[MickG]

Try this:-
Place code in worksheet module.
Code runs when data altered in column "I".

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]

@MickG 's is more elegant. Here's another approach.

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

 

[jmacleary]

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]

@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]

Thank you @MickG

I am thinking of making this code better by having Day, Week, Month, Year. Would this be easier to change?

 

[MickG]

Try this:-

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