kod yazarak otomatik yaş hesaplama

[furens]

exel sayfasının kod bölümene a sütununda her hangi bir hücreye tarih girildiğinden b sütunundaki karşılığına gelen hücreye otomatik olarak yıl-ay-gün olarak yaşının gelmesi için formül yazabilirmisiniz.eğer değer yoksa herhangibir ileti geolmayacak tarih değilse tarih girin uyarısı gelebilir.şimdiden teşekkürler.

 

[Civan Jack]

Kodlar Sn. Tarkan VURAL'a aittir.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "A1" Then Exit Sub
    On Local Error Resume Next
    Dim tarih As Date, dogum As Date
    Dim fark As Long
    Dim yil As Integer, ay As Integer, gun As Integer
    Dim yildankalan As Integer, aydankalan As Integer
    tarih = VBA.Date
    dogum = CDate(Target.Value)
    If Err.Number = 13 Then
        MsgBox "Hatalı tarih, yaş hesaplanamadı.", vbCritical, "Www."
            Err.Clear
                Exit Sub
    End If
    fark = tarih - dogum
    Select Case fark
        Case Is > 365
            yil = Mid(fark / 365, 1, InStrRev((fark / 365), ",", -1, 1) - 1) * 1
            yildankalan = fark - (yil * 365)
        Case Else
            yildankalan = fark
    End Select
    Select Case yildankalan
        Case Is >= 30
            ay = Mid(yildankalan / 30, 1, InStrRev((yildankalan / 30), ",", -1, 1) - 1) * 1
            aydankalan = yildankalan - (ay * 30)
            If ay = 12 Then yil = yil + 1: ay = 0
        Case Else
            gun = yildankalan
    End Select
    If gun = 0 Then gun = aydankalan
        Range("C1").Value = yil & " yıl " & ay & " ay " & gun & " gün"
            If yil < 18 Then MsgBox "18 yaşından küçük !   ", vbCritical, "Dikkat !!!"

tarih = Empty: dogum = Empty: fark = Empty: yil = Empty: ay = Empty
gun = Empty: yildankalan = Empty:aydankalan = Empty
End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kodları sayfanın kod bölümüne kopyalayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    
    If Target.Value = "" Then Target.Offset(0, 1) = ""
    If IsDate(Target.Value) = False Then Exit Sub
    
    Dim Tarih  As String
    
    Tarih = Evaluate("DateDif(" & CDbl(Target.Value) & "," & CDbl(CDate(Date)) & ", ""y"")") & " Yıl "
    Tarih = Tarih & Format(Evaluate("DateDif(" & CDbl(Target.Value) & "," & CDbl(CDate(Date)) & ", ""ym"")"), "00") & " Ay "
    Tarih = Tarih & Format(Evaluate("DateDif(" & CDbl(Target.Value) & "," & CDbl(CDate(Date)) & ", ""md"")"), "00") & " Gün"
    Target.Offset(0, 1) = Tarih
    
End Sub

 

[furens]

civan jack tşk.eerim emeğin için kodda hata var yanlış hesaplıyor ayrıca sadece a1 hücresi için geçerliymiş.yinede sağol

Nejdet YEŞETENER sizede tşk.sizin yazdığınız koduda yazdım oldu tşk.ama a sütutuna birden fazla tarih kopyalayıp yapıştırdığım zaman hata veriyor ona bakabilrmisiniz

 

[furens]

Nejdet YEŞETENER hocam ben sanırım soruyu yanlış sormuşun kısmen doğru ama ben kendim isteğime göre uyarlarm demiştim ama formülü çözemedim.
Yani; her hangi bir sütuna bu a olur b olur doğum tarihi girdiğimde yine değişterebileceğim sütunu -g- sütunu yada e sütununa otomatik yıl-ay-gün olarak yaşın gelmesi tekrar düzenleyebilirseniz çok tşk.ederim.

 

[furens]

hocam tmm çözdüm If Target.Value = "" Then Target.Offset(0, 1
Target.Offset(0, 1) = Tarih
buradaki 1 rakamlarını değiştirirsek istenilen hücreye yazması sağlanıyormuş

 

[Necdet]

hocam tmm çözdüm If Target.Value = "" Then Target.Offset(0, 1
Target.Offset(0, 1) = Tarih
buradaki 1 rakamlarını değiştirirsek istenilen hücreye yazması sağlanıyormuş

Sorunuzu anlamadığım gibi çözüm şeklinizi de anlamadım. Ama sanırım yaptınız sorun yok. Güle güle kullanınız.