Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2007 Perşembe

Files Collection



'Module1

Sub Files_Collection()
On Error Resume Next
FihristGöster "c:\"
End Sub
Sub FihristGöster(Fihrist)
On Error Resume Next
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Fihrist)
Set fc = f.Files
For Each f1 In fc
s = s & f1.Name
s = s & vbCrLf
Next
MsgBox s & VBA.Chr(13) & VBA.Chr(13) & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] File Collection..."
End Sub

10 Aralık 2007 Pazartesi

Condition Statements (Select Case, For Each, For Next, Do Loop, Do While, While)


'Module1

Sub DÖNGÜ_ForNext()
On Error GoTo Hata:
Dim Hafıza(1 To 24, 1 To 1)
For i = 1 To 24
Hafıza(i, 1) = i
Next i
[A1:A24].Value = Hafıza
For Sayaç = 1 To 24
If (Cells(Sayaç, 1) > 20) Then
With Cells(Sayaç, 2)
.Value = Application.WorksheetFunction.Max(Range(Cells(1, 2), Cells(24, 2))) + 1
With .Interior
.ColorIndex = 4
.Pattern = xlPatternCrissCross
End With
With .Font
.Bold = True
.Color = vbWhite
End With
End With
End If
Next Sayaç
Hata:
End Sub
Sub DÖNGÜ_ForEachNext()
On Error GoTo Hata:
Dim Hafıza(1 To 65536, 1 To 1)
For i = 1 To 65536
Hafıza(i, 1) = VBA.Rnd
Next i
[A1:A65536].Value = Hafıza
For Each Hücre In Range("A1:A65536")
If (Hücre.Value > 0.6) Then
With Hücre.Offset(0, 1).Interior

.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next Hücre
Hata:
End Sub
Sub DÖNGÜ_SelectCase()
On Error GoTo Hata:
Dim Bulgu
Dim Hafıza(1 To 12, 1 To 1)
For i = 1 To 12
Hafıza(i, 1) = i
Next i
[A1:A12].Value = Hafıza
[A6].Select
Bulgu = Selection.Offset(0, 0).Row
Select Case Bulgu
Case 1 :Selection.Offset(0, 1) = Selection.Row
Case 2 :Selection.Offset(0, 1) = Selection.Row
Case 3 :Selection.Offset(0, 1) = Selection.Row
Case 4 :Selection.Offset(0, 1) = Selection.Row
Case 5 :Selection.Offset(0, 1) = Selection.Row
Case 6 :Selection.Offset(0, 1) = Selection.Row
Case 7 :Selection.Offset(0, 1) = Selection.Row
Case 8 :Selection.Offset(0, 1) = Selection.Row
Case 9 :Selection.Offset(0, 1) = Selection.Row
Case 10 :Selection.Offset(0, 1) = Selection.Row
Case 11 :Selection.Offset(0, 1) = Selection.Row
Case 12 :Selection.Offset(0, 1) = Selection.Row
End Select
Hata:
End Sub Sub DÖNGÜ_DoLoop1()
On Error GoTo Hata:
Do
Range("A1") = Range("A1") + 1
Loop
Hata:
End Sub
Sub DÖNGÜ_DoLoop2()
On Error GoTo Hata:
Do
Range("A1") = Range("A1") + 1
If Range("A1") = 50 Then Exit Do
Loop
Hata:
End Sub
Sub DÖNGÜ_DoUntilLoop1()
On Error GoTo Hata:
Dim i As Single
Dim Satır As Double
Dim Hafıza(1 To 40, 1 To 1)
Satır = 0
[A1].Select
For i = 1 To 40
Hafıza(i, 1) = i
Next i
[A1:A40].Value = Hafıza
Do Until (Selection.Offset(Satır, 0).Row > 20)
If (Selection.Offset(Satır, 0).Value <> "") Then
With Selection.Offset(Satır, 1)
.Interior.ColorIndex = 6
.Interior.Pattern = xlSolid
.Offset(Satır, 1) = Selection.Offset(Satır, 0).Row
End With
End If
Selection.Offset(Satır + 1, 0).Select
Loop
Hata:
End Sub
Sub DÖNGÜ_DoUntilLoop2()
On Error Resume Next
Dim i As Integer
Dim Ölçüt(1 To 4) As String
Dim Karşılık As String
Dim İşaret As Boolean
İşaret = False
Ölçüt(1) = "A"
Ölçüt(2) = "B"
Ölçüt(3) = "C"
Ölçüt(4) = "D"
Do Until İşaret = True
Karşılık = InputBox("Lütfen kendi seçiminizi giriniz: (A,B,C or D)")
For i = 1 To 4
If UCase(Karşılık) = UCase(Ölçüt(i)) Then
İşaret = True: Exit For
End If
Next i
Loop
End Sub
Sub DÖNGÜ_DoUntilLoop3()
On Error Resume Next
If IsEmpty(ActiveCell) Then Exit Sub
Do Until IsEmpty(ActiveCell)
MsgBox ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub DÖNGÜ_DoUntilLoop4()
On Error Resume Next
Dim i As Integer
Dim Dosya As String
Dosya = Dir("C:\*.XLS")
i = 1
Do Until Dosya = ""
Cells(i, 1) = Dosya
Dosya = Dir
i = i + 1
Loop
End Sub
Sub DÖNGÜ_DoLoopUntil()
On Error GoTo Hata:
Dim i As Integer
i = 1
Do
Cells(i, 1).Value = i
i = i + 1
Loop Until (i > 10)
Hata:
End Sub
Sub DÖNGÜ_GoTo1()
On Error GoTo Hata:
Dim i As Integer
i = InputBox("1-100 arasında bir sayı giriniz")
GoTo Topla
Topla:
i = i + 20
MsgBox "Girdiğiniz sayının 20 fazlası:" & i
Hata:
End Sub
Sub DÖNGÜ_GoTo2()
On Error GoTo Hata:
If IsEmpty(ActiveCell) Then Exit Sub
Top:
MsgBox ActiveCell.Value
ActiveCell.Offset(1, 0).Select
If Not IsEmpty(ActiveCell) Then GoTo Top
Hata:
End Sub
Sub DÖNGÜ_While()
On Error GoTo Hata:
Dim Değer As Variant
Dim Sayaç, Topla As Double
Değer = Val(InputBox("Sıfırdan farklı değer giriniz"))
Sayaç = 0
Topla = 0
While Değer > 0
Topla = Topla + Değer
Sayaç = Sayaç + 1
Değer = Val(InputBox("Sonraki deger"))
Wend
MsgBox ("Toplanan Adet: " & Sayaç & " Toplam Değer: " & Topla)
Hata:
End Sub

1 Aralık 2007 Cumartesi

GetOpenFilename / GetSaveAsFilename



'Module1

Option Explicit

Sub GetOpenFilename()
     Dim Bilgi
     Dim Sayaç%
     On Error GoTo Hata
     Cells.Columns(1).ClearContents
     Cells(1, 1).Select
     Bilgi = Application.GetOpenFilename("All Files (*.*), *.*", "123", "[PBİD®]”)

     GetOpenFilename", MultiSelect:=True)
     For Sayaç = LBound(Bilgi) To UBound(Bilgi)

          Cells(Sayaç, 1) = Bilgi(Sayaç)
     Next Sayaç
Hata:
End Sub

Sub GetSaveAsFilename()
     Dim Bilgi
     Dim Sayaç%
     On Error GoTo Hata
     Cells.Columns(1).ClearContents
     Cells(1, 1).Select
     Bilgi = Application.GetSaveAsFilename("FarklıKaydetAdı", fileFilter:="Text Files (*.txt), *.txt", FilterIndex:=2)
     For Sayaç = LBound(Bilgi) To UBound(Bilgi)

          Cells(Sayaç, 1) = Bilgi(Sayaç)
     Next Sayaç
Hata:
End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi