Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ekim 2008 Pazartesi

Twelve-Level Progress Account



'UserForm1

'Add Tools on UserForm1: ProgressBar1....12, Label1....16, CommandButton1, Image1, Label17
Option Explicit
Dim i As Long
Dim ii As Long
Dim iii As Long
Dim iv As Long
Dim v As Long
Dim vi As Long
Dim vii As Long
Dim viii As Long
Dim ix As Long
Dim x As Long
Dim xi As Long
Dim xii As Long

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] Twelve-Level Progress Account..."
ProgressBar1.Max = 12: ProgressBar1.Min = 1
ProgressBar2.Max = 11: ProgressBar2.Min = 1
ProgressBar3.Max = 10: ProgressBar3.Min = 1
ProgressBar4.Max = 9: ProgressBar4.Min = 1
ProgressBar5.Max = 8: ProgressBar5.Min = 1
ProgressBar6.Max = 7: ProgressBar6.Min = 1
ProgressBar7.Max = 6: ProgressBar7.Min = 1
ProgressBar8.Max = 5: ProgressBar8.Min = 1
ProgressBar9.Max = 4: ProgressBar9.Min = 1
ProgressBar10.Max = 3: ProgressBar10.Min = 1
ProgressBar11.Max = 2: ProgressBar11.Min = 1
ProgressBar12.Max = 1: ProgressBar12.Min = 1
Hata:
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Label13.Caption = VBA.Format(Now, "hh:mm:ss")
For i = 1 To 12
ProgressBar1.Value = i: Label1.Caption = "%" & VBA.Round((i / 12) * 100, 2): DoEvents
For ii = 1 To 11
ProgressBar2.Value = ii: Label2.Caption = "%" & VBA.Round((ii / 11) * 100, 2): DoEvents
For iii = 1 To 10
ProgressBar3.Value = iii: Label3.Caption = "%" & VBA.Round((iii / 10) * 100, 2): DoEvents
For iv = 1 To 9
ProgressBar4.Value = iv: Label4.Caption = "%" & VBA.Round((iv / 9) * 100, 2): DoEvents
For v = 1 To 8
ProgressBar5.Value = v: Label5.Caption = "%" & VBA.Round((v / 8) * 100, 2): DoEvents
For vi = 1 To 7
ProgressBar6.Value = vi: Label6.Caption = "%" & VBA.Round((vi / 7) * 100, 2): DoEvents
For vii = 1 To 6
ProgressBar7.Value = vii: Label7.Caption = "%" & VBA.Round((vii / 6) * 100, 2): DoEvents
For viii = 1 To 5
ProgressBar8.Value = viii: Label8.Caption = "%" & VBA.Round((viii / 5) * 100, 2): DoEvents
For ix = 1 To 4
ProgressBar9.Value = ix: Label9.Caption = "%" & VBA.Round((ix / 4) * 100, 2): DoEvents
For x = 1 To 3
ProgressBar10.Value = x: Label10.Caption = "%" & VBA.Round((x / 3) * 100, 2): DoEvents
For xi = 1 To 2
ProgressBar11.Value = xi: Label11.Caption = "%" & VBA.Round((xi / 2) * 100, 2): DoEvents
For xii = 1 To 1
ProgressBar12.Value = xii: Label12.Caption = "%" & VBA.Round((xii / 1) * 100, 2): DoEvents
Next xii
Next xi
Next x
Next ix
Next viii
Next vii
Next vi
Next v
Next iv
Next iii
Next ii
Next i
Label14.Caption = VBA.Format(Now, "hh:mm:ss")
Hata:
End Sub

10 Ekim 2008 Cuma

To Consolidate Duplicate Records




'UserForm1

'Add Tools On UserForm1: ListBox1, CommandButton1, Label, Image1, Label2
Option Explicit
Dim Seçim As Variant
Dim i As Long, No As Long
Dim Bulunan As Range
Dim Hesaplanan As Double

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] To Consolidate Duplicate Records..."
Call BilgiGetir
Hata:
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Durak1:
No = Cells(65536, 2).End(xlUp).Row
For i = 1 To No
Seçim = Cells(i, 2).Value
Hesaplanan = 0
Hesaplanan = Hesaplanan + Cells(i, 3).Value
If ((i + 1) > No) Then Exit For
For Each Bulunan In Range(Cells((i + 1), 2), Cells(No, 2))
If Seçim = Bulunan Then
Hesaplanan = Hesaplanan + VBA.Val(Bulunan.Offset(0, 1))
Bulunan.EntireRow.Delete
Application.Cells(i, 3).Value = Hesaplanan
GoTo Durak1
End If
Next Bulunan
Next i
Call BilgiGetir
Exit Sub
Hata:
End Sub
Sub BilgiGetir()
On Error GoTo Hata
Hesaplanan = 0
No = Cells(65536, 2).End(xlUp).Row
ReDim Hafıza(1 To No, 1 To 3)
For i = 1 To No
Hafıza(i, 1) = Cells(i, 1)
Hafıza(i, 2) = Cells(i, 1).Offset(0, 1)
Hafıza(i, 3) = Cells(i, 1).Offset(0, 2)
Hesaplanan = Hesaplanan + VBA.Val(Hafıza(i, 3))
Next
With ListBox1
.ColumnCount = 3
.ColumnWidths = "24;150;36"
.List() = Hafıza()
End With
Label1.Caption = Hesaplanan
End Sub

1 Ekim 2008 Çarşamba

Workbook Menu




'ThisWorkbook

Option Explicit
Private Sub Workbook_Open()
     On Error Resume Next
     Call Menü_Kur
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     On Error Resume Next
     Call Menü_Yoket

End Sub

'Module1

Option Explicit
Public Const Sistem_Menü = "Worksheet Menu Bar"
Public Const Program_Menüsü = "PBİD®"
Dim Eleman$
Dim Alt_Eleman$
Sub Menü_Kur()
     On Error Resume Next
     Program_Menüsü_Temizle
Program_Menüsü
     Application.CommandBars.Add Program_Menüsü, , True 'CommandBar / ToolBarMenüsü

     Eleman = "&Bir"
     CommandBars(Program_Menüsü).Controls.Add(Type:=msoControlPopup).Caption = Eleman
     With CommandBars(Program_Menüsü).Controls(Eleman)

          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .FaceId = 3
               .State = msoButtonUp
               .Enabled = True
               .BeginGroup = False

          End With
          Eleman = "Menü&2"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .State = msoButtonDown
               .Enabled = False
               .BeginGroup = True
               .FaceId = 4

          End With
          Eleman = "Menü&3"
          .Controls.Add(Type:=msoControlEdit).Caption = Eleman
          With .Controls(Eleman)

               .Tag = "TestEditBox"
               .Text = "Yazılı Komutunuz"
               .OnAction = "Komut"

          End With
          Alt_Eleman = "Menü&4"
          .Controls.Add(Type:=msoControlPopup).Caption = Alt_Eleman
          With .Controls(Alt_Eleman)

               Eleman = "Alt Menü&1"
               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)

                    .OnAction = "Komut"
               End With
               Eleman = "Alt Menü&2"
               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)

                    .OnAction = "Komut"
               End With
               Eleman = "Alt Menü&3"

               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)
                    .OnAction = "Komut"
               End With
          End With
          Eleman = "Menü&5"
          .Controls.Add(Type:=msoControlComboBox).Caption = Eleman
          With .Controls(Eleman)

               '.Delete
               .OnAction = "Komut1"
               .Visible = True
               .Enabled = True
               .AddItem "Bir"
               .AddItem "İki"
               .AddItem "Üç"
               .AddItem "Dört"
               .AddItem "Beş"
               .AddItem "Altı"
               .ListIndex = 4
               .DropDownWidth = 36

          End With
          Eleman = "Menü&6"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .State = msoButtonDown
               .BeginGroup = True

          End With
     End With
     Eleman = "&İki"
     CommandBars(Program_Menüsü).Controls.Add(msoControlPopup).Caption = Eleman
     With CommandBars(Program_Menüsü).Controls(Eleman)

          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          .Controls(Eleman).OnAction = "Komut"
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .BeginGroup = True

          End With
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
          End With
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .BeginGroup = True

          End With
     End With
     CommandBars(Program_Menüsü).Visible = True

End Sub

'Module2

Option Explicit
Dim Menü_Bar_Elemanı

Sub Kullanılan_Menü()
     On Error Resume Next
     MsgBox CommandBars.ActiveMenuBar.Name

End Sub
Sub Sistem_Menüsü_Düzenle()
     On Error Resume Next
     CommandBars(Sistem_Menü).Visible = True

End Sub
Sub Program_Menüsü_Düzenle()
     On Error Resume Next
     CommandBars(Program_Menüsü).Visible = True

End Sub
Sub Menü_Yoket()
     On Error Resume Next
     Program_Menüsü_Temizle Program_Menüsü

End Sub
Sub Program_Menüsü_Temizle(Menü_Adı)
     On Error Resume Next
     For Each Menü_Bar_Elemanı In CommandBars

          If Menü_Bar_Elemanı.Name = Menü_Adı Then
                Menü_Bar_Elemanı.Delete
          End If
     Next
End Sub
Sub Komut()
     On Error Resume Next
     MsgBox CommandBars.FindControl(Tag:="TestEditBox").Text

End Sub
Sub Komut1()
     On Error Resume Next
     Dim Seçim
     Seçim = CommandBars(Program_Menüsü).Controls("Bir").Controls("Menü5").ListIndex
     Select Case Seçim

          Case 1 :MsgBox "1"
          Case 2 :MsgBox "2"
          Case 3 :MsgBox "3"
          Case 4 :MsgBox "4"
          Case 5 :MsgBox "5"
          Case 6 :MsgBox "6"
     End Select
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