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

KyleJackMorrison

Board Regular
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
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
@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:

KyleJackMorrison

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

MickG

MrExcel MVP
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
 

Some videos you may like

This Week's Hot Topics

  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • find many based on a certain criteria
    good evening, I hope someone can help me? I have a workbook sheet 2 contains lots of data.... I would like to be able to find anything on sheet...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
  • Text Format
    I have a sheet for user to keyin the data. The format of the data can be 451 / 1903, 0012 / 9908 or 00287 / 0099. The number after the "/" is...
  • Syntax errors
    Good Morning, Trying to compile a workbook, I keep getting a few errors. Here are the first two: [code=rich]Syntax Error: Function...
Top