Soru kalan günü hesaplama

[sirkülasyon]

excel sayfasında H4:H500 aralığında bir hücreye tarih yazıldığında I4:I500 de güncel tarihe göre
Aradaki fark önce yılı, yıl yoksa ay, ay yoksa gün gösterecek ve gün değiştikçe de azalan şekilde bir makro ile tarih hesaplama yapılabilir mi?
Saygılarımla

 

[PLİNT]

Merhaba
Ek dosyayı denermisiniz?
https://dosyaup.com/d/YIJOAJVVM

"Sayfa1" kod penceresinde

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H4:H500")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
If IsDate(Target.Value) = False Then MsgBox "Tarih hatalı": Exit Sub
Call kalan_zaman
End Sub

"Modüle 1" de

Sub auto_open()
Call kalan_zaman
End Sub


Sub kalan_zaman()
Dim i As Date, s As Date, g As Integer, t As Long, z As Date, c As Long, k As Date
Dim h As Double, a As Integer, y As Integer, j As Long, jj As Long, nn As String, pl As Range

Set s1 = Sheets("Sayfa1")

For Each pl In s1.Range("H4:H500")
If IsDate(pl) = True And pl <> "" Then
i = CDate(Date): s = CDate(pl)
If CDate(i) > CDate(s) Then MsgBox "Yazılan tarih bugünden önce olamaz": Target = "": Exit Sub
t = Month(i): g = -1
z = DateSerial(Year(CDate(i)), Month(CDate(i)) + 1, 0)
If Day(i) = Day(z) Then j = 1
For c = CDbl(i) To CDbl(s)
g = g + 1
k = DateSerial(Year(CDate(c)), Month(CDate(c)) + 1, 0)
If Month(CDate(c)) <> t Then
If Day(k) = Day(CDate(c)) Then jj = j + 1
If Day(i) = Day(CDate(c)) Then h = True
If Day(k) < Day(z) And Day(CDate(c)) = Day(k) Then h = True
If jj = 2 Then h = True
End If
If h = True Then
t = Month(CDate(c))
a = a + 1
g = 0
h = 0
jj = j
End If
If a = 12 Then
y = y + 1: a = 0
End If
Next
If g > 0 Then nn = g & " GÜN"
If a > 0 Then nn = a & " AY"
If y > 0 Then nn = y & " YIL"

s1.Cells(pl.Row, "I") = nn
End If
g = 0: a = 0: y = 0
Next
End Sub

 

[PLİNT]

Günü geçenler için de düzenleme bulunan aşağıdaki dosyayı deneyin
https://dosyaup.com/d/WSPOK

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H4:H500")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
If IsDate(Target.Value) = False Then MsgBox "Tarih hatalı": Exit Sub
If CDate(Date) > CDate(Target) Then MsgBox "Yazılan tarih bugünden önce olamaz": Target = "": Exit Sub
Call kalan_zaman
End Sub

Sub auto_open()
Call kalan_zaman
End Sub

Sub kalan_zaman()
Dim i As Date, s As Date, g As Integer, t As Long, z As Date, c As Long, k As Date
Dim h As Double, a As Integer, y As Integer, j As Long, jj As Long, nn As String, pl As Range

Set s1 = Sheets("Sayfa1")

For Each pl In s1.Range("H4:H500")
If IsDate(pl) = True And pl <> "" Then
i = CDate(Date): s = CDate(pl)
If CDate(i) > CDate(s) Then s1.Cells(pl.Row, "I") = "GEÇMİŞ": GoTo 10
t = Month(i): g = -1
z = DateSerial(Year(CDate(i)), Month(CDate(i)) + 1, 0)
If Day(i) = Day(z) Then j = 1
For c = CDbl(i) To CDbl(s)
g = g + 1
k = DateSerial(Year(CDate(c)), Month(CDate(c)) + 1, 0)
If Month(CDate(c)) <> t Then
If Day(k) = Day(CDate(c)) Then jj = j + 1
If Day(i) = Day(CDate(c)) Then h = True
If Day(k) < Day(z) And Day(CDate(c)) = Day(k) Then h = True
If jj = 2 Then h = True
End If
If h = True Then
t = Month(CDate(c))
a = a + 1
g = 0
h = 0
jj = j
End If
If a = 12 Then
y = y + 1: a = 0
End If
Next
If g > 0 Then nn = g & " GÜN"
If a > 0 Then nn = a & " AY"
If y > 0 Then nn = y & " YIL"

s1.Cells(pl.Row, "I") = nn
End If
10:
g = 0: a = 0: y = 0
Next pl

End Sub

 

[sirkülasyon]

Emek vererek, zaman harcadığınız ve yardımınızı esirgemediğiniz için size teşekkür ederim.
Çok çok sağ olun

 

[PLİNT]

Merhaba
Rica ederim, güle güle kullanın.
Siz yukarıdaki gibi istemişsiniz ama aşağıdaki gibi "****" işaretli bölümün altını değiştirirseniz yıl,ay, günü sonucu sıfır olmayanlar gösteririr

Sub kalan_zaman()
'................
'................kodlarınız
'.......................
'.................
If a = 12 Then
y = y + 1: a = 0
End If
Next
'*********************************
nn = ""
If y > 0 Then nn = y & " YIL "
If a > 0 Then nn = nn & " " & a & " AY "
If g > 0 Then nn = nn & " " & g & " GÜN"
If nn = "" Then nn = "BUGÜN"
s1.Cells(pl.Row, "I") = nn
End If
10:
g = 0: a = 0: y = 0
Next pl
End Sub

 

[sirkülasyon]

Allah yar ve yardımcın Olsun
Çok çok teşekkür ederim. Sağ olasın