Looking for a formula or VBA code that will return the age in the same cell where I had input the birthdate

[milt2010]

Hello to all,
as I wrote in the title, I would like to enter a birth date in a cell and get the corresponding age back in the same cell, after I press return or another key.

Thanks in advance for any help

 

[JustynaMK]

Hi,

You can use the following code:

Private Sub Worksheet_Change(ByVal Target As Range)


    If Not Intersect(Target, Me.Range("[COLOR=#ff0000]A1:A10[/COLOR]")) Is Nothing Then
        Application.EnableEvents = False
            With Target
                If IsDate(.Text) And .Cells.Count = 1 Then
                    .Value = DateDiff("yyyy", .Value, Date)
                    .NumberFormat = "@"
                End If
            End With
        Application.EnableEvents = True
    End If


End Sub

Open your VBA window (Alt+F11), double-click on a sheet where you want this Change Event to be triggered, and paste this code there.
You can also change a Target range from A1:A10 to any range where you want this code to work.

Let me know if this is what you were looking for.

 

[milt2010]

Yes, that's exactly what I was looking for! Thank you very much!

 

[JustynaMK]

happy to help!

 

[milt2010]

Hello again! I entered the code in a worksheet where there are also other codes and initially it worked perfectly. Then, I do not know why, it started not working anymore. The bug message I receive is: Runtime error 1004: Unebla to set the number of the property of the range class "with the error that appears in the image I attached.
Any idea? https://1drv.ms/f/s!AtkvD-EXoGv6jpAdDlWzfeHNyqvU8g

 

[My Aswer Is This]

You need to show us all the code you have in this sheet.
The script worked for me.

And I never click on links or open files.
Do not say: Just open or look at my link. If you want help from me

 

[Michael M]

The code works fine for me.
But, you can only have 1 worksheet code in a Sheet Module....so you might need to combine codes.

 

[milt2010]

You need to show us all the code you have in this sheet.
The script worked for me.

And I never click on links or open files.
Do not say: Just open or look at my link. If you want help from me

Thank you and ok, My Aswer Is This, but I can't to attach the worksheet, sorry... I can only post the all code in the worksheet.

Thank you too Michael M. Yes, it 's true, even to me it works well alone. But when I insert it along with the other codes it stops working.

This is the all code(s) in the Worksheet:

'''''''''''''''''
'BIRTHDATE CODE '
'''''''''''''''''
Private Sub Worksheet_Change(ByVal Target As Range)


    If Not Intersect(Target, Me.Range("J1:J300")) Is Nothing Then
        Application.EnableEvents = False
            With Target
                If IsDate(.Text) And .Cells.Count = 1 Then
                    .Value = DateDiff("yyyy", .Value, Date)
                   [COLOR=#00ff00].NumberFormat = "@"[/COLOR] ''here is the problem ("Runtime error 1004: Unable to set the number  of the property of the range class")
                End If
            End With
        Application.EnableEvents = True
    End If
''''''''''''''''''''''''''''''
'"if" CODE AUTONUMBER COLOUMN'
''''''''''''''''''''''''''''''
If Intersect(Target, Range("E5:E300,M5:M300,D5:T300")) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Application.Calculation = xlManual
If Target.Column = 5 Then
Dim i As Long
Range("D5:D300").ClearContents
For i = 5 To Cells(Rows.Count, 5).End(xlUp).Row
Cells(i, 4).FormulaR1C1 = "=IF(RC[1]="""","""",SUBTOTAL(3,R5C5:RC[1]))"
Next i
End If
If Target.Column = 11 Then
'Dim i As Long
Dim b As Integer
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For Each c In Range("K5:K300")
For b = 1 To Lastrow
If c.Value = Cells(b, 1).Value Then c.Value = Cells(b, 2).Value
Next
Next
End If
''''''''''''''''''''''''''
'Autofit + UpperCase CODE'
''''''''''''''''''''''''''
If Target.Column >= 4 And Target.Column <= 12 Then
If Target.Cells.Count > 1 Or Target.HasFormula Then ''interpretazione da controllare
Application.Calculation = xlAutomatic
Calculate
Application.EnableEvents = True
Exit Sub
End If
Target = UCase(Target)
Sheets("List").Columns("D:T").AutoFit
End If
Application.Calculation = xlAutomatic
Calculate
Application.EnableEvents = True
End Sub
'''''''''''''''''''
'HYPERLINK CODE   '
'''''''''''''''''''
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 14 Then Exit Sub
Dim rngFound As Range
    With Worksheets("Respons.").Columns(5) 'Guarda in quale colonna cercare
         Set rngFound = .Find(Target.Offset(0, -6).Value, LookIn:=xlValues,  LookAt:=xlWhole, After:=.Cells(1), Searchdirection:=xlNext)
        If Not rngFound Is Nothing Then
            Application.Goto rngFound(1, Target.Value + 1)
        Else
            MsgBox "There were not matches found for " & Target(1, -5).Value
        End If
    End With
Cancel = True
End Sub

 

[Michael M]

Post your worksheet to DropBox then post the link back here.

The worksheet isn't protected is it ???

 

[milt2010]

Ok, I'll post it on the dropbox. Normally I would like it to be protected (always via VBA code) but I post it without protection ...