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

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