Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Eylül 2004 Pazartesi

Date Text Format




'UserForm1

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Date Text Format..."
With TextBox1
.MaxLength = 10
.EnterFieldBehavior = fmEnterFieldBehaviorRecallSelection
.Text = "##.##.####"
.SelStart = 0
.SelLength = 1
End With
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
With TextBox1
.SelLength = 1
If .SelText = "." Then
.SelStart = .SelStart + 1
.SelLength = 1
End If
End With
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error GoTo Hata:
With TextBox1
If KeyCode = vbKeyLeft Or KeyCode = vbKeyBack Then
KeyCode = vbKeySelect
.SelStart = .SelStart - 1
.SelLength = 1
ElseIf KeyCode = vbKeyRight Then
KeyCode = vbKeySelect
.SelStart = .SelStart + 1
.SelLength = 1
ElseIf KeyCode = vbKeyDelete Then
KeyCode = vbKeySelect
If .SelText = "." Then
.SelText = "."
Else
.SelText = "#"
End If
.SelStart = .SelStart - 1
.SelLength = 1
ElseIf KeyCode = vbKeyHome Then
KeyCode = vbKeySelect
.SelStart = 0
.SelLength = 1
ElseIf KeyCode = vbKeyEnd Then
KeyCode = vbKeySelect
.SelStart = Len(TextBox1) - 1
.SelLength = 1
End If
End With
Exit Sub
Hata:
KeyCode = vbKeySelect
TextBox1.SelStart = 0
TextBox1.SelLength = 1
End Sub

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

1 Eylül 2004 Çarşamba

Data Sort on Sheet





'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL'Name: Excel, Description: Microsoft Excel 11.0 Object Library, Full Path: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE'Name: stdole, Description: OLE Automation, Full Path: C:\WINDOWS\system32\stdole2.tlb
'Name: Office, Description: Microsoft Office 11.0 Object Library, Full Path: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\WINDOWS\system32\FM20.DLL
'B) UserForm1'e Eklenen Araçlar (Add Tools)
'ListBox1, CommandButton1, CommandButton2, Label1
Option Explicit
Dim i, j As Single
Dim Hücre As Range
Dim Bellek(1 To 20, 1 To 10)
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Data Sort on Sheet"
Call EkranDüzenle
Call VeriDüzenle
End Sub
Private Sub CommandButton1_Click()
'Number Sort

On Error GoTo 0
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Call Sırala
End Sub
Private Sub CommandButton2_Click()
'Name Sort

On Error GoTo 0
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Call Sırala
End Sub
Private Sub Sırala()
'Sort

On Error GoTo 0
i = 1: j = 1
For Each Hücre In Sheets(1).Range("A1:B81")
If Hücre.Column = 1 Then
If i > 0 And i <= 20 Then Bellek(j, 1) = Hücre.Value
If i > 20 And i <= 40 Then Bellek(j, 3) = Hücre.Value
If i > 40 And i <= 60 Then Bellek(j, 5) = Hücre.Value
If i > 60 And i <= 80 Then Bellek(j, 7) = Hücre.Value
If i > 80 And i <= 100 Then Bellek(j, 9) = Hücre.Value
Else
If i > 0 And i <= 20 Then Bellek(j, 2) = Hücre.Value
If i > 20 And i <= 40 Then Bellek(j, 4) = Hücre.Value
If i > 40 And i <= 60 Then Bellek(j, 6) = Hücre.Value
If i > 60 And i <= 80 Then Bellek(j, 8) = Hücre.Value
If i > 80 And i <= 100 Then Bellek(j, 10) = Hücre.Value
i = i + 1
j = j + 1
If (j > 20) Then j = 1
End If
Next Hücre
ListBox1.List() = Bellek
End Sub
Private Sub EkranDüzenle()
'Form Creation

On Error Resume Next
With Me
.Height = 258
.Width = 444
.BackColor = vbWhite
With ListBox1
.Left = 6
.Top = 6
.Height = 204
.Width = 428
.TextAlign = fmTextAlignLeft
.SpecialEffect = fmSpecialEffectEtched
.BackColor = vbWhite
.ColumnCount = 10
.ColumnWidths = "18 pt;66 pt;18 pt;66 pt;18 pt;66 pt;18 pt;66 pt;18 pt;66 pt"
.Clear
.BackColor = &H80000013
.ForeColor = vbBlue
End With
With CommandButton1
.Left = 6
.Top = ListBox1.Top + ListBox1.Height + 6
.Width = 72
.Height = 18
.Caption = "Number Sort"
End With
With CommandButton2
.Left = CommandButton1.Left + CommandButton1.Width + 6
.Top = ListBox1.Top + ListBox1.Height + 6
.Width = 72
.Height = 18
.Caption = "Name Sort"
End With
With Label1
.Top = ListBox1.Top + ListBox1.Height + 6
.Left = CommandButton2.Left + CommandButton2.Width + 6
.Height = 12
.Width = 270
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = vbBlue
.Caption = "Mustafa ULUSARAÇ, 01ulusarac@superonline.com"
End With
End With
End Sub
Private Sub VeriDüzenle()
'Data Creation

On Error Resume Next
Sheets(1).Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Cells(1, 1) = 1: Cells(1, 2) = "Adana"
Cells(2, 1) = 2: Cells(2, 2) = "Adıyaman"
Cells(3, 1) = 3: Cells(3, 2) = "Afyon"
Cells(4, 1) = 4: Cells(4, 2) = "Ağrı"
Cells(5, 1) = 5: Cells(5, 2) = "Amasya"
Cells(6, 1) = 6: Cells(6, 2) = "Ankara"
Cells(7, 1) = 7: Cells(7, 2) = "Antalya"
Cells(8, 1) = 8: Cells(8, 2) = "Artvin"
Cells(9, 1) = 9: Cells(9, 2) = "Aydın"
Cells(10, 1) = 10: Cells(10, 2) = "Balıkesir"
Cells(11, 1) = 11: Cells(11, 2) = "Bilecik"
Cells(12, 1) = 12: Cells(12, 2) = "Bingöl"
Cells(13, 1) = 13: Cells(13, 2) = "Bitlis"
Cells(14, 1) = 14: Cells(14, 2) = "Bolu"
Cells(15, 1) = 15: Cells(15, 2) = "Burdur"
Cells(16, 1) = 16: Cells(16, 2) = "Bursa"
Cells(17, 1) = 17: Cells(17, 2) = "Çanakkale"
Cells(18, 1) = 18: Cells(18, 2) = "Çankırı"
Cells(19, 1) = 19: Cells(19, 2) = "Çorum"
Cells(20, 1) = 20: Cells(20, 2) = "Denizli"
Cells(21, 1) = 21: Cells(21, 2) = "Diyarbakır"
Cells(22, 1) = 22: Cells(22, 2) = "Edirne"
Cells(23, 1) = 23: Cells(23, 2) = "Elazığ"
Cells(24, 1) = 24: Cells(24, 2) = "Erzincan"
Cells(25, 1) = 25: Cells(25, 2) = "Erzurum"
Cells(26, 1) = 26: Cells(26, 2) = "Eskişehir"
Cells(27, 1) = 27: Cells(27, 2) = "Gaziantep"
Cells(28, 1) = 28: Cells(28, 2) = "Giresun"
Cells(29, 1) = 29: Cells(29, 2) = "Gümüşhane"
Cells(30, 1) = 30: Cells(30, 2) = "Hakkari"
Cells(31, 1) = 31: Cells(31, 2) = "Hatay"
Cells(32, 1) = 32: Cells(32, 2) = "Isparta"
Cells(33, 1) = 33: Cells(33, 2) = "İçel"
Cells(34, 1) = 34: Cells(34, 2) = "İstanbul"
Cells(35, 1) = 35: Cells(35, 2) = "İzmir"
Cells(36, 1) = 36: Cells(36, 2) = "Kars"
Cells(37, 1) = 37: Cells(37, 2) = "Kastamonu"
Cells(38, 1) = 38: Cells(38, 2) = "Kayseri"
Cells(39, 1) = 39: Cells(39, 2) = "Kırklareli"
Cells(40, 1) = 40: Cells(40, 2) = "Kırşehir"
Cells(41, 1) = 41: Cells(41, 2) = "Kocaeli"
Cells(42, 1) = 42: Cells(42, 2) = "Konya"
Cells(43, 1) = 43: Cells(43, 2) = "Kütahya"
Cells(44, 1) = 44: Cells(44, 2) = "Malatya"
Cells(45, 1) = 45: Cells(45, 2) = "Manisa"
Cells(46, 1) = 46: Cells(46, 2) = "Kahramanmaraş"
Cells(47, 1) = 47: Cells(47, 2) = "Mardin"
Cells(48, 1) = 48: Cells(48, 2) = "Muğla"
Cells(49, 1) = 49: Cells(49, 2) = "Muş"
Cells(50, 1) = 50: Cells(50, 2) = "Nevşehir"
Cells(51, 1) = 51: Cells(51, 2) = "Niğde"
Cells(52, 1) = 52: Cells(52, 2) = "Ordu"
Cells(53, 1) = 53: Cells(53, 2) = "Rize"
Cells(54, 1) = 54: Cells(54, 2) = "Sakarya"
Cells(55, 1) = 55: Cells(55, 2) = "Samsun"
Cells(56, 1) = 56: Cells(56, 2) = "Siirt"
Cells(57, 1) = 57: Cells(57, 2) = "Sinop"
Cells(58, 1) = 58: Cells(58, 2) = "Sivas"
Cells(59, 1) = 59: Cells(59, 2) = "Tekirdağ"
Cells(60, 1) = 60: Cells(60, 2) = "Tokat"
Cells(61, 1) = 61: Cells(61, 2) = "Trabzon"
Cells(62, 1) = 62: Cells(62, 2) = "Tunceli"
Cells(63, 1) = 63: Cells(63, 2) = "Şanlıurfa"
Cells(64, 1) = 64: Cells(64, 2) = "Uşak"
Cells(65, 1) = 65: Cells(65, 2) = "Van"
Cells(66, 1) = 66: Cells(66, 2) = "Yozgat"
Cells(67, 1) = 67: Cells(67, 2) = "Zonguldak"
Cells(68, 1) = 68: Cells(68, 2) = "Aksaray"
Cells(69, 1) = 69: Cells(69, 2) = "Bayburt"
Cells(70, 1) = 70: Cells(70, 2) = "Karaman"
Cells(71, 1) = 71: Cells(71, 2) = "Kırıkkale"
Cells(72, 1) = 72: Cells(72, 2) = "Batman"
Cells(73, 1) = 73: Cells(73, 2) = "Şırnak"
Cells(74, 1) = 74: Cells(74, 2) = "Bartın"
Cells(75, 1) = 75: Cells(75, 2) = "Ardahan"
Cells(76, 1) = 76: Cells(76, 2) = "Iğdır"
Cells(77, 1) = 77: Cells(77, 2) = "Yalova"
Cells(78, 1) = 78: Cells(78, 2) = "Karabük"
Cells(79, 1) = 79: Cells(79, 2) = "Kilis"
Cells(80, 1) = 80: Cells(80, 2) = "Osmaniye"
Cells(81, 1) = 81: Cells(81, 2) = "Düzce"
End Sub 

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