Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Eylül 2006 Çarşamba

Dimensional DBase

'Module1

'A) Tek Boyutlu Sabit (Dimensional) Diziler

Option Base 1
Dim Arr(5)

Sub TekBoyutluSabitDiziler1()
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5)
End Sub

'Module2

'B) Çok Boyutlu Değişken(ReDimensional) Diziler

Option Base 1

Sub ÇokBoyutluDeğişkenDiziler1()
On Error Resume Next
ReDim Arr(6)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5)
End Sub
Sub ÇokBoyutluDeğişkenDiziler2()
On Error Resume Next
ReDim Arr(5)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
ReDim Arr(6)
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5) & "-" & Arr(6)
End Sub
Sub ÇokBoyutluDeğişkenDiziler3()
On Error Resume Next
ReDim Arr(5)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
ReDim Preserve Arr(6)
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5) & "-" & Arr(6)
End Sub

'Module3

'C) Çok Boyutlu Sabit(Dimensional) Diziler

Option Base 1
Dim Arr(2, 2)

Sub ÇokBoyutluSabitDizi1()
On Error Resume Next
Arr(1, 1) = 1000
Arr(1, 2) = 1200
Arr(2, 1) = 1500
Arr(2, 2) = 2000
MsgBox "Sale of CD in 2003 is " & Arr(1, 1) & vbCrLf & "Sale of CD in 2004 is " & Arr(2, 1) & vbCrLf & "Sale of DVD in 2003 is " & Arr(1, 2) & vbCrLf & "Sale of DVD in 2004 is " & Arr(2, 2)
End Sub

'Module4

'D) Dizilerin Büyük [Ubound] ve Küçük [Lbound] Değeri

Option Base 1
Dim A(1 To 100, 0 To 3, -3 To 4)
Dim x(6)

Sub DizilerinBüyükKüçükDeğeri1()
On Error Resume Next
x(1) = UBound(A, 1) '= 100
x(2) = UBound(A, 2) '= 3
x(3) = UBound(A, 3) '= 4
x(4) = LBound(A, 1) '= 1
x(5) = LBound(A, 2) '= 0
x(6) = LBound(A, 3) '= -3
MsgBox x(1) & vbCrLf & x(2) & vbCrLf & x(3) & vbCrLf & x(4) & vbCrLf & x(5) & vbCrLf & x(6)
End Sub
Sub DizilerinBüyükKüçükDeğeri2()
On Error Resume Next
x(1) = UBound(A, 1) - LBound(A, 1) + 1 '100 - 1 + 1
x(2) = UBound(A, 2) - LBound(A, 2) + 1 ' 3 - 0 + 1
x(3) = UBound(A, 3) - LBound(A, 3) + 1 '4 - (-3) + 1
MsgBox x(1) & vbCrLf & x(2) & vbCrLf & x(3)
End Sub

'Module5

'E) Dizi Sıralama

Option Explicit
Option Base 1
Dim Arr(5) As Integer
Dim Liste As String
Dim Temp As Double
Dim i, j As Long

Sub Sırala()
On Error Resume Next
Arr(1) = 8
Arr(2) = 4
Arr(3) = 3
Arr(4) = 7
Arr(5) = 2
Liste = ""
For i = 1 To 5
Liste = Liste & Arr(i) & vbCrLf
Next i
MsgBox "Before Sorting" & vbCrLf & Liste
Call Sıralatma(Arr)
Liste = ""
For i = 1 To 5
Liste = Liste & Arr(i) & vbCrLf
Next i
MsgBox "After Sorting" & vbCrLf & Liste
End Sub
Sub Sıralatma(Arr() As Integer)
On Error Resume Next
For j = 1 To UBound(Arr)
Temp = Arr(j)
For i = j - 1 To 1 Step -1
If (Arr(i) <= Temp) Then GoTo Durak: Arr(i + 1) = Arr(i)
Next i
i = 0
Durak:
Arr(i + 1) = Temp
Next j
End Sub

'Module6

'F) Rastgele (Resample/Random) Değeri Bulma

Option Explicit
Option Base 1
Dim Hold(8) As Single, Hold2(8) As String
Dim str As String
Dim xTemp As Double
Dim yTemp As String
Dim i As Long
Dim j As Long

Sub Rastgele()
On Error Resume Next
Hold2(1) = "Anthony"
Hold2(2) = "Bobby"
Hold2(3) = "Chris"
Hold2(4) = "Danny"
Hold2(5) = "Eton"
Hold2(6) = "Frank"
Hold2(7) = "George"
Hold2(8) = "Harry"
For i = 1 To UBound(Hold)
Hold(i) = VBA.Rnd
Cells(i, 2) = Hold(i)
Next i
Call DoubleSort(Hold, Hold2)
str = ""
For i = 1 To 3
str = str & Hold2(i) & vbCrLf
Cells(i, 1) = Hold2(i)
Next i
MsgBox str
End Sub
Sub DoubleSort(x() As Single, y() As String)
On Error Resume Next
For j = 2 To UBound(x)
xTemp = x(j)
yTemp = y(j)
For i = j - 1 To 1 Step -1
If (x(i) <= xTemp) Then GoTo Durak: x(i + 1) = x(i) y(i + 1) = y(i)
Next i
i = 0
Durak:
x(i + 1) = xTemp
y(i + 1) = yTemp
Next j
End Sub

'UserForm1

'G) Dizi İçinde Dikey ve Yatay Arama


'Application.Vlookup(Aranan,Array,Sütun,False)
'Application.Hlookup(Aranan,Array,Satır,False)
'Application.Match(Aranan,Array,0)


Option Explicit
Dim i
Dim Alan(20, 3)
Dim Alan1(20, 0)
Dim Bilgi

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Height = 96
.Width = 172
.Caption = "[PBİD®]Dizi İçi Arama..."
End With
With ListBox1
.ColumnCount = 3
.ColumnWidths = "36;36;36"
.Left = 6
.Top = 6
.Height = 60
.Width = 118
End With
For i = 1 To 5
With Me("Label" & i)
.Left = 126
.Width = 36
.Top = (i - 1) * 12 + 6
End With
DoEvents
Next i
Me.Repaint
For i = 0 To (20 - 1)
Alan1(i, 0) = "A" & (i + 1)
Alan(i, 0) = "A" & (i + 1)
Alan(i, 1) = "B" & (i + 1)
Alan(i, 2) = "C" & (i + 1)
Next i
ListBox1.List() = Alan
End Sub
Private Sub ListBox1_Click()
On Error Resume Next
Bilgi = ListBox1.Value
Label1.Caption = Application.WorksheetFunction.Match(Bilgi, Alan1, 0)
Label2.Caption = Application.WorksheetFunction.VLookup(Bilgi, Alan, 3, False)
Label3.Caption = Application.WorksheetFunction.Index(Alan, Label1.Caption, 3)
Label4.Caption = Application.WorksheetFunction.CountA(Alan1)
Label5.Caption = Application.WorksheetFunction.CountA(Alan)
End Sub

10 Eylül 2006 Pazar

Choose Dim DBase


'UserForm1

Option Explicit
Dim Alan
Dim Aranan
Dim i As Long

Private Sub ListBox1_Click()
On Error Resume Next
TextBox1.Text = ListBox1.List(ListBox1.ListIndex, 0)
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
Aranan = TextBox1.Text
Label1.Caption = Application.VLookup(Aranan, Alan, 2, False)
Label2.Caption = Application.VLookup(Aranan, Alan, 3, False)
Label3.Caption = Application.VLookup(Aranan, Alan, 4, False)
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
ReDim Alan1(10000, 4)
For i = 0 To (10000 - 1)
Alan1(i, 0) = "Adı" & (i + 1)
Alan1(i, 1) = "Soyadı" & (i + 1)
Alan1(i, 2) = "Yaşı" & (i + 1)
Alan1(i, 3) = "Okulu" & (i + 1)
Next i
ListBox1.List() = Alan1
Alan = Alan1
End Sub

1 Eylül 2006 Cuma

Computer Name by GetComputerName Function


'Module1

Option Explicit
Private Declare Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA" (ByVal lbbuffer As String, nsize As Long)
Dim BilgiAdı As String * 64

Sub Bilgisayar_Adı()

On Error Resume Next
Call GetComputerName(BilgiAdı, 64)
MsgBox "Bilgisayar Adı= " & BilgiAdı
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