Results 1 to 7 of 7

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

  1. #1
    Board Regular
    Join Date
    Dec 2013
    Location
    Portsmouth, Hampshire
    Posts
    80
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

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

    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

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

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

    Try this:-
    Place code in worksheet module.
    Code runs when data altered in column "I".
    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim nstr As String
    Application.EnableEvents = False
    If Target.Column = 9 And Len(Target.Value) = 2 And IsDate(Target.Offset(, -1).Value) Then
        If Left(Target.Value, 1) Like "[1-9]" And UCase(Right(Target.Value, 1)) = "W" Or UCase(Right(Target.Value, 1)) = "Y" Then
            Select Case UCase(Right(Target.Value, 1))
                Case "Y": Target.Value = DateAdd("yyyy", Left(Target.Value, 1), Target.Offset(, -1).Value)
                Case "W": Target.Value = DateAdd("ww", Left(Target.Value, 1), Target.Offset(, -1).Value)
            End Select
       End If
    End If
    Application.EnableEvents = True
    End Sub
    Regards Mick

  3. #3
    Board Regular CalcSux78's Avatar
    Join Date
    Oct 2013
    Location
    STL
    Posts
    1,120
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    @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 by CalcSux78; Jul 16th, 2019 at 10:09 AM.
    Cunningham's Law: "The best way to get the right answer on the Internet is not to ask a question, it's to post the wrong answer."

  4. #4
    Board Regular jmacleary's Avatar
    Join Date
    Oct 2015
    Location
    at a desk in the UK
    Posts
    668
    Post Thanks / Like
    Mentioned
    15 Post(s)
    Tagged
    0 Thread(s)

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

    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.
    If my answer has helped, please vote using the Thanks or Like buttons on the left.
    John

  5. #5
    Board Regular
    Join Date
    Dec 2013
    Location
    Portsmouth, Hampshire
    Posts
    80
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

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

    @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))"

  6. #6
    Board Regular
    Join Date
    Dec 2013
    Location
    Portsmouth, Hampshire
    Posts
    80
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

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

    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 by KyleJackMorrison; Jul 16th, 2019 at 10:34 AM.

  7. #7
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

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

    Try this:-
    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim nstr As String, Num As Long
    Dim Apha As String
     Apha = "YMWD"
    Application.EnableEvents = False
    If Target.Column = 9 And IsDate(Target.Offset(, -1).Value) Then
        Num = Left(Target.Value, Len(Target.Value) - 1)
        If IsNumeric(Num) And InStr(Apha, UCase(Right(Target.Value, 1))) > 0 Then
            
            Select Case UCase(Right(Target.Value, 1))
                Case "Y": Target.Value = DateAdd("yyyy", Num, Target.Offset(, -1).Value)
                Case "M": Target.Value = DateAdd("m", Num, Target.Offset(, -1).Value)
                Case "W": Target.Value = DateAdd("WW", Num, Target.Offset(, -1).Value)
                Case "D": Target.Value = DateAdd("d", Num, Target.Offset(, -1).Value)
            End Select
       End If
    End If
    Application.EnableEvents = True
    End Sub
    Regards Mick

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •