Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2008 Cuma

Data Base Management on UserForm's ListBox







'UserForm1

Option Explicit
Dim i As Single
Dim KaynakAdres As String
Dim No, Adet As Double

Private Sub UserForm_Initialize()
     On Error Resume Next
     Me.Caption = "[PBİD®] Data Base Management on UserForm's ListBox..."
     Adet = Application.WorksheetFunction.CountA(Range("B2:B65536"))
     If (Adet > 0) Then
          KaynakAdres = "Veri!A2:D" & (Adet + 1)
          With ListBox1
              .List() = Range(KaynakAdres).Value
              .ColumnCount = 4
              .ColumnWidths = "36;90;90;66"
              .Width = (36 + 90 + 90 + 66 + 12)
              .Height = 90.75
              .ListIndex = 0
          End With
     Else
          With ListBox1
               .ColumnCount = 4
               .ColumnWidths = "36;90;90;66"
               .Width = (36 + 90 + 90 + 66 + 12)
              .Height = 90.75
              .AddItem 1
              .List(0, 1) = ""
              .List(0, 2) = ""
              .List(0, 3) = ""
              Adet = .ListCount
              .ListIndex = 0
              No = 0
          End With
     End If
     TextBox1.Locked = True
End Sub

Private Sub UserForm_Activate()
     On Error Resume Next
     Do
          Label6.Caption = ListBox1.ListCount
          Vba.DoEvents
     Loop
End Sub

Private Sub UserForm_Terminate()
     On Error Resume Next
     Call KayıtGüncelle
End Sub

Private Sub ListBox1_Click()
     On Error Resume Next
     No = ListBox1.ListIndex
     TextBox1.Value = ListBox1.List(No, 0)
     TextBox2.Value = ListBox1.List(No, 1)
     TextBox3.Value = ListBox1.List(No, 2)
     TextBox4.Value = ListBox1.List(No, 3)
End Sub

Private Sub TextBox2_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 1) = TextBox2.Value
End Sub

Private Sub TextBox3_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 2) = TextBox3.Value
End Sub

Private Sub TextBox4_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 3) = TextBox4.Value
End Sub

Private Sub CommandButton1_Click() 'Kayıt Ekle
     On Error Resume Next
     No = ListBox1.ListIndex
     With ListBox1
           .AddItem "", No
           .List(No, 1) = ""
           .List(No, 2) = ""
           .List(No, 3) = ""
           Adet = .ListCount
           .ListIndex = No
           For i = 0 To (Adet - 1)
                .List(i, 0) = (i + 1)
           Next i
           TextBox1.Value = .List(No, 0)
           TextBox2.Value = .List(No, 1)
           TextBox3.Value = .List(No, 2)
           TextBox4.Value = .List(No, 3)
      End With
End Sub

Private Sub CommandButton2_Click() 'Kayıt Sil
     On Error Resume Next
     If MsgBox("Silme işlemine devam etmek istiyormusunuz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbOKCancel, "[PBİD®] Lütfen Dikkat") = vbCancel Then Exit Sub
     No = ListBox1.ListIndex
     If (Adet > 0) Then
          TextBox1.Value = ""
          TextBox2.Value = ""
          TextBox3.Value = ""
          TextBox4.Value = ""
          With ListBox1
               .RemoveItem No
               Adet = .ListCount
               If (Adet > 0) Then
                    For i = 0 To (Adet - 1)
                         .List(i, 0) = (i + 1)
                    Next i
                    No = .ListIndex
                    TextBox1.Value = .List(No, 0)
                    TextBox2.Value = .List(No, 1)
                    TextBox3.Value = .List(No, 2)
                    TextBox4.Value = .List(No, 3)
               Else
                    .AddItem 1
                    .List(0, 1) = ""
                    .List(0, 2) = ""
                    .List(0, 3) = ""
                    Adet = .ListCount
                    .ListIndex = 0
                    No = 0
               End If
          End With
     End If
End Sub

Private Sub CommandButton3_Click() 'Güncelle      On Error Resume Next
     Call KayıtGüncelle
End Sub

Sub KayıtGüncelle()
     On Error Resume Next
     If MsgBox("Tüm veri tabanı değişecektir. Güncelleme işlemine devam etmek istiyormusunuz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbOKCancel, "[PBİD®] Lütfen Dikkat") = vbCancel Then Exit Sub
     With ListBox1
          Range("A2:D65536").ClearContents
          Adet = .ListCount
          KaynakAdres = "Veri!A2:D" & (Adet + 1)
          Range(KaynakAdres) = .List()
     End With
End Sub

10 Haziran 2008 Salı

Data Base Management on UserForm





'UserForm1

Option Explicit
Dim SBKontrol As Double
Dim i, No, ÖncekiNo, Adet As Integer
Dim Bakılan, Alan As Range
Dim Adres As String

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Data Base Management on UserForm..."
ÖncekiNo = 0
No = 1
Adet = Application.WorksheetFunction.CountA(Range("B2:B65000"))
If Adet > 0 Then
With SpinButton1
.SmallChange = 1
.Max = Adet
.Min = 1
.Value = 1
End With
Else
With SpinButton1
.SmallChange = 1
.Max = 0
.Min = 0
.Value = 0
End With
End If
Sheets("Veri").Select
TextBox1.Locked = True
ComboBox1.RowSource = "Veri!B2:B65536"
End Sub
Private Sub SpinButton1_Change()
On Error Resume Next
If SBKontrol = 0 Then
Adet = Application.WorksheetFunction.Count(Range("A2:A65000"))
Adres = "A2:D" & (Adet + 1)
No = SpinButton1.Value
Call VeriGönder
Call VeriGetir
ÖncekiNo = No
Range(Cells((No + 1), 1), Cells((No + 1), 4)).Select
End If
End Sub
Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 2) = TextBox2.Text
End Sub
Private Sub TextBox3_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 3) = TextBox3.Text
End Sub
Private Sub TextBox4_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 4) = TextBox4.Text
End Sub
Private Sub ComboBox1_Click()
On Error Resume Next
If Adet > 0 Then
No = VeriTarama(ComboBox1.Value, 2)
Call VeriGönder
Call VeriGetir
ÖncekiNo = No
Range(Cells((No + 1), 1), Cells((No + 1), 4)).Select
End If
End Sub
Private Sub CommandButton1_Click() 'Kayıt Ekle
On Error Resume Next
SBKontrol = 1
If Adet > 0 Then
Selection.EntireRow.Insert
Adet = Adet + 1
For i = 1 To Adet
Cells((i + 1), 1) = i
Next i
With SpinButton1
.Min = 1
.Max = Adet
End With
ÖncekiNo = ÖncekiNo + 1
Adres = "A2:D" & Application.WorksheetFunction.Count(Range("A2:A65000")) + 1
Call VeriGönder
Call VeriGetir
ÖncekiNo = ÖncekiNo - 1
Else
Adet = Adet + 1
Cells(2, 1) = 1
With SpinButton1
.Min = 1
.Max = 1
.Value = 1
End With
No = 1
ÖncekiNo = 1
Adres = "A2:D2"
Call VeriGetir
Range(Cells((No + 1), 1), Cells((No + 1), 4)).Select
End If
SBKontrol = 0
End Sub
Private Sub CommandButton2_Click() 'Kayıt Sil
On Error Resume Next
SBKontrol = 1
If Adet > 0 Then
Selection.EntireRow.Delete
Adet = Adet - 1
If Adet > 0 Then
With SpinButton1
.Min = 1
.Max = Adet
End With
For i = 1 To Adet
Cells((i + 1), 1) = i
Next i
Call VeriGetir
Else
With SpinButton1
.Min = 0
.Max = 0
End With
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
End If
End If
SBKontrol = 0
End Sub
Private Function VeriTarama(ByVal Taranan As Variant, ByVal Sütun As Double)
On Error Resume Next
i = 0
If Sütun = 2 Then
For Each Bakılan In Range("B2:B" & Application.WorksheetFunction.CountA(Range("B2:B65536")))
i = i + 1
If Bakılan.Value = Taranan Then
VeriTarama = i
Exit Function
End If
Next Bakılan
Else
End If
End Function
Sub VeriGönder()
On Error Resume Next
If ÖncekiNo > 0 Then
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 1) = TextBox1.Text
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 2) = TextBox2.Text
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 3) = TextBox3.Text
Sheets("Veri").Range(Adres).Cells(ÖncekiNo, 4) = TextBox4.Text
End If
End Sub
Sub VeriGetir()
On Error Resume Next
If No > 0 Then
TextBox1.Text = Sheets("Veri").Range(Adres).Cells(No, 1)
TextBox2.Text = Sheets("Veri").Range(Adres).Cells(No, 2)
TextBox3.Text = Sheets("Veri").Range(Adres).Cells(No, 3)
TextBox4.Text = Sheets("Veri").Range(Adres).Cells(No, 4)
End If
End Sub

1 Haziran 2008 Pazar

UserForm ComboBox KeyUp Controls




'UserForm1

Option Explicit
Dim i As Single

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] UserForm ComboBox KeyUp Controls..."
For i = 1 To 100
ComboBox1.AddItem "Kayıt " & i
Next i
End Sub

Private Sub UserForm_Activate()
On Error Resume Next
ComboBox1.ListIndex = 5
ComboBox1.SetFocus
ComboBox1.DropDown
End Sub
Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
ComboBox1 = Empty
ComboBox1.SetFocus
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