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

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
90
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
796
Office Version
2007
Platform
Windows
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
90
@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
90
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,082,334
Messages
5,364,677
Members
400,810
Latest member
elbashka

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top