Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Eylül 2004 Cuma

Date Difference



'UserForm1

'A) Additional Tools

'A1) Label1, Label2, Label3
'A2) TextBox1, TextBox2, TextBox3
'A3) CommandButton1

Option Explicit
Dim t1, t2, t3
Dim YF As Integer 'Yıl Farkı [Year Difference]
Dim AF As Integer 'Ay Farkı [Month Difference]
Dim GF As Integer 'Gün Farkı [Day Difference]
Dim Tarih As Date
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] Date Difference..."
    Call Ekran_Kur

End Sub
Private Sub CommandButton1_Click()

    On Error Resume Next
    t1 = TextBox1.Value 'İlk Tarihi [Start Date]
    t2 = TextBox2.Value 'Son Tarihi [Finish date]
    t3 = Tarihfarki(VBA.CDate(t1), VBA.CDate(t2))
    TextBox3.Value = t3 'Tarihi Farkı [Date Difference]

End Sub
Private Function Tarihfarki(D1 As Date, D2 As Date) As Variant

    On Error Resume Next
    If D1 > D2 Then
        Tarih = D1
        D1 = D2
        D2 = Tarih
    End If
    YF = VBA.Year(D2) - VBA.Year(D1)
    If VBA.DateSerial(VBA.Year(D2), VBA.Month(D1), VBA.Day(D1)) > D2 Then
        YF = YF - 1
    End If
    If VBA.Month(D2) > VBA.Month(D1) Then
        If VBA.Day(D2) > VBA.Day(D1) Or VBA.Day(D2) = VBA.Day(D1) Then
            AF = VBA.Month(D2) - VBA.Month(D1)
        Else
            AF = VBA.Month(D2) - VBA.Month(D1) - 1
        End If
    Else
        If VBA.Day(D2) > VBA.Day(D1) Or VBA.Day(D2) = VBA.Day(D1) Then AF = VBA.Month(D2) - VBA.Month(D1) + 12
        If AF = 12 Then
            AF = 0
        Else
            AF = VBA.Month(D2) - VBA.Month(D1) + 11
        End If
    End If
    If VBA.Day(D2) > VBA.Day(D1) Or VBA.Day(D2) = VBA.Day(D1) Then
        GF = VBA.Day(D2) - VBA.Day(D1)
    Else
        GF = VBA.Day(VBA.DateSerial(VBA.Year(D1), VBA.Month(D1) + 1, 1) - 1) - VBA.Day(D1) + VBA.Day(D2)
    End If
    Tarihfarki = YF & " Yıl " & AF & " Ay " & GF & " Gün"
    If YF = 0 Then
        Tarihfarki = AF & " Ay " & GF & " Gün"
    End If
    If AF = 0 Then
        Tarihfarki = YF & " Yıl " & GF & " Gün"
    End If
    If GF = 0 Then
        Tarihfarki = YF & " Yıl " & AF & " Ay "
    End If

End Function
Sub Ekran_Kur()

    On Error Resume Next
    With Me
        .Height = 180
        .Width = 240
        .BackColor = VBA.RGB(242, 242, 242)
        With Label1
            .Left = 6
            .Top = 6
            .Height = 18
            .Width = 114
            .Caption = " İlk Tarih [Start Date]"
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With TextBox1
            .Left = 126
            .Top = 6
            .Height = 18
            .Width = 102
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
        End With
        With Label2
            .Left = 6
            .Top = 30
            .Height = 18
            .Width = 114
            .Caption = " Son Tarih [Finish Date]"
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With TextBox2
            .Left = 126
            .Top = 30
            .Height = 18
            .Width = 102
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Text = VBA.Format(VBA.Now(), "dd.mm.yyyy")
        End With
        With Label3
            .Left = 6
            .Top = 54
            .Height = 18
            .Width = 114
            .Caption = " Tarih Farkı [Date Difference]"
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With TextBox3
            .Left = 126
            .Top = 54
            .Height = 18
            .Width = 102
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
        End With
        With CommandButton1
            .Left = 6
            .Top = 78
            .Height = 24
            .Width = 222
            .Caption = "Hesapla"
        End With
    End With
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul