Makro Kod Listesi

Excel de kullanılan Makro Kodlarının Listesi

ID : 2041
ISLEM : şarta göre mesajbox görüntüleme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$B$1" Then Exit Sub If [b1] < [a1] Then MsgBox "girdiğiniz değer yanlış" End Sub

ID : 2042
ISLEM : şartlara göre aktif yada pasif olan komut düğmesi
MAKRO KODU : Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then CommandButton1.Enabled = False Else CommandButton1.Enabled = True End If End Sub ilk başta komut düğmesinin enable özelliğini false yapmayı unutmayın.

ID : 2043
ISLEM : şartlı wav çaldırma
MAKRO KODU : Sub Auto_Open() Worksheets("Sayfa1").OnCalculate = "PlayIt" End Sub Sub PlayIt() If Range("A1").Value > 5 Then ExecuteExcel4Macro ("SOUND.PLAY(,""C:\Windows\Media\Tada.wav"")") End If End Sub

ID : 2044
ISLEM : şekillerin alanlarını hesaplama
MAKRO KODU : Private Sub Command1_Click() Dim a, b, c As Double If Option1.Value = True Then a = Val(Text1.Text) b = 3.14 * a ^ 2 Text3.Text = b End If If Option2.Value = True Then a = Val(Text1.Text) b = a ^ 2 Text3.Text = b End If If Option3.Value = True Then a = Val(Text1.Text) b = Val(Text2.Text) c = a * b Text3.Text = c End If If Option4.Value = True Then a = Val(Text1.Text) b = Val(Text2.Text) c = (a * b) / 2 Text3.Text = c End If End Sub Private Sub option1_click() Text1.Text = "" Text2.Text = "" Text3.Text = "" Label2.Visible = False Text2.Visible = False Label1.Caption = "yarıçap(r)" Label3.Caption = "Alan" End Sub Private Sub option2_click() Text1.Text = "" Text2.Text = "" Text3.Text = "" Label2.Visible = False Text2.Visible = False Label1.Caption = "Kenar(a)" Label3.Caption = "Alan" End Sub Private Sub option3_click() Text1.Text = "" Text2.Text = "" Text3.Text = "" Label2.Visible = True Text2.Visible = True Label1.Caption = "Kenar(a)" Label2.Caption = "Kenar(b)" Label3.Caption = "Alan" End Sub Private Sub option4_click() Text1.Text = "" Text2.Text = "" Text3.Text = "" Label2.Visible = True Text2.Visible = True Label1.Caption = "Taban(a)" Label2.Caption = "Yükseklik(h)" Label3.Caption = "Alan" End Sub

ID : 2045
ISLEM : şıfreleme de son nokta
MAKRO KODU : Bu komut Visual Basic ve VBA da dahili bir komut olduğu için herhangi bir ön hazırlığa gerek duymaz. Görevi : Windows kayıt defteri(registry)ne kayıt yapar. Kullanımı : SaveSetting Program(uygulama) adı, Bölüm, Anahtar, Değer Private Sub CommandButton1_Click() 'Bu prosedürde registry'e en son girilen kaydedilir. SaveSetting "partner", "Settings", "UserForm1", TextBox1.Text End Sub Yukarıdaki prosedirde registere gerekli kayıt yapılıyor. Aşağıdaki prosedürde ise registry'e kaydedilen bilgi TextBoxa geri çağrılıyor. Kayıtları okumak için GetSetting komutu kullanılır. SaveSetting'in tersidir. Kullanımı: Değişken = GetSetting (Program adı, Bölüm, Anahtar, [Kayıt Yoksa Değer]) Kayıt Yoksa Değer parametresi zorunlu değildir. Registerde belirtilen kayıt yoksa varsayılan olarak atanacak değeri buraya yazabilirsiniz. Private Sub UserForm_Initialize() 'UserFormdaki TextBox1 e yazdığınız en son bilgi UserForm aktif olduğunda tekrar çağırılır TextBox1.Text = GetSetting("partner", "Settings", "UserForm1") End Sub Peki bu kayıt register'in neresinde diye soranlara? Başlat / Çalıştır 'a regedit yazıp enter'e basın. Aşağıdaki görülen resimdeki adrese ulaşın. Kaydı orada göreceksiniz.

ID : 2046
ISLEM : şıfreli giriş 0-254 arası bir sayı
MAKRO KODU : ThisWorkbook'a Private Sub Workbook_Open() Test1 End Sub Sub Test1() Dim NumberofColumns As Integer Dim BMax As Integer Dim InputErrorCheck As Boolean InputErrorCheck = False Do While InputErrorCheck = False NumberofColumns = Application.InputBox(prompt:="Şifre kodunuzu giriniz ", Type:=1) If IsNumeric(NumberofColumns) Then If NumberofColumns <= 254 And NumberofColumns > 0 Then ' Şifre kodunun 0-254 arası bir sayı olduğu varsayılmıştır. InputErrorCheck = True End If End If If NumberofColumns = False Then MsgBox ("İşlem iptal edildi") Exit Sub End If Loop MsgBox (NumberofColumns) ' Burada input alındıktan sonra esas yapılmamk istenen işlem prosedürleri çağrılacak End Sub

ID : 2047
ISLEM : şıfreli giriş userformda textboxlu
MAKRO KODU : 2 adet TextBox 1.si şifre 2.Şifre Tekrar yazma '1 adet Command Buton giriş Private Sub CommandButton1_Click() If TextBox1.Value = "kubilay" Or TextBox1.Value = "B" Then GoTo Kontrol2 Else Unload UserForm1 MsgBox "TEKRAR DENE İSTERSEN OLMADI!", vbCritical, "HATA" ActiveWorkbook.Close 0 Exit Sub End If Kontrol2: If TextBox2.Value = "kubilay" Or TextBox2.Value = "2" Then MsgBox "Programa girişiniz onaylanmıştır.", vbInformation Unload Me Application.Visible = True Else Unload UserForm1 MsgBox "Üzgünüm girdiğiniz parola hatalı.", vbCritical, "HATA" ActiveWorkbook.Close 0 Exit Sub End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 Then Cancel = True End Sub

ID : 2048
ISLEM : şıfreli yazıyı deşifre etme
MAKRO KODU : Public gszData As String Public Sub DemoEncryptData() gszData = CStr(Application.InputBox("Enter a string to be encrypted.", "Encyrption Demo")) If (gszData <> CStr(False)) And (Len(gszData) > 0) Then EncryptDecrypt gszData MsgBox "The encrypted string is:" & vbLf & vbLf & gszData, vbInformation, "Encryption Demo" Else gszData = vbNullString End If End Sub Public Sub DemoDecryptData() If Len(gszData) > 0 Then EncryptDecrypt gszData MsgBox "The decrypted string is:" & vbLf & vbLf & gszData, vbInformation, "Encryption Demo" Else MsgBox "There is no stored data to decrypt.", vbExclamation, "Encryption Demo" End If End Sub Private Sub EncryptDecrypt(ByRef szData As String) Const lKEY_VALUE As Long = 215 Dim bytData() As Byte Dim lCount As Long bytData = szData For lCount = LBound(bytData) To UBound(bytData) bytData(lCount) = bytData(lCount) Xor lKEY_VALUE Next lCount szData = bytData End Sub

ID : 2049
ISLEM : şıfreyi girince kodlar tekrar aktif olsun
MAKRO KODU : If Date >= CDate("23.02.2005") Then sifre = InputBox("Devam edebilmek için şifre girmelisiniz!", "Progranım Kullanım Süresi Dolmuştur") If sifre <> "1234" Then Exit Sub End If MsgBox "Çalışan kodlar"

ID : 2050
ISLEM : şıfreyi girmeye zorlama girince diğer sayfaya yönlendirir
MAKRO KODU : Sub Registrierung() ActiveWindow.DisplayWorkbookTabs = False Worksheets("Codeabfrage").Select On Error GoTo Abbruch Application.EnableCancelKey = xlErrorHandler Application.DisplayAlerts = False Heute = Now Verfalldatum = #5/14/2003# 'Hier Verfalldatum im Format MM/TT/JJJJ eintragen If Verfalldatum < Heute Then Dim passwort As String passwort = InputBox("Die Testphase ist abgelaufen," & Chr(13) & Chr(13) & " bitte geben Sie Ihre Registrierungs-Nr.:", "Testphase abgelaufen, Reg.Nr. erforderlich") If passwort <> "36" Then Registrierung End If MsgBox ("Registrierung erfolgreich") ActiveWindow.DisplayWorkbookTabs = True Worksheets("Datenbereich").Select Application.DisplayAlerts = True End If Exit Sub Aufraeumen: Application.EnableCancelKey = xlInterrupt ThisWorkbook.Close Exit Sub Abbruch: ThisWorkbook.Close End Sub

ID : 2051
ISLEM : şifre açma
MAKRO KODU : Sub sifreac() Dim a As Integer For a = 1 To 10000 Application.DisplayAlerts = False Workbooks.Open Filename:="C:\Documents and Settings\usak0018\Belgelerim\YTL.xls", Password:=a Next a End Sub

ID : 2052
ISLEM : şifrelemede son nokta
MAKRO KODU : Bu komut Visual Basic ve VBA da dahili bir komut olduğu için herhangi bir ön hazırlığa gerek duymaz. Görevi : Windows kayıt defteri(registry)ne kayıt yapar. Kullanımı : SaveSetting Program(uygulama) adı, Bölüm, Anahtar, Değer Private Sub CommandButton1_Click() 'Bu prosedürde registry'e en son girilen kaydedilir. SaveSetting "partner", "Settings", "UserForm1", TextBox1.Text End Sub Yukarıdaki prosedirde registere gerekli kayıt yapılıyor. Aşağıdaki prosedürde ise registry'e kaydedilen bilgi TextBoxa geri çağrılıyor. Kayıtları okumak için GetSetting komutu kullanılır. SaveSetting'in tersidir. Kullanımı: Değişken = GetSetting (Program adı, Bölüm, Anahtar, [Kayıt Yoksa Değer]) Kayıt Yoksa Değer parametresi zorunlu değildir. Registerde belirtilen kayıt yoksa varsayılan olarak atanacak değeri buraya yazabilirsiniz. Private Sub UserForm_Initialize() 'UserFormdaki TextBox1 e yazdığınız en son bilgi UserForm aktif olduğunda tekrar çağırılır TextBox1.Text = GetSetting("partner", "Settings", "UserForm1") End Sub Peki bu kayıt register'in neresinde diye soranlara? Başlat / Çalıştır 'a regedit yazıp enter'e basın. Aşağıdaki görülen resimdeki adrese ulaşın. Kaydı orada göreceksiniz.

ID : 2053
ISLEM : şifreli kapali bir dosyadan veri almak
MAKRO KODU : Aşağıdaki kodu güncelleştirme yapılan dosyanın thisworkbook sayfasına kopyalayın. Dosyayı her açtığınızda link olan tüm dosyaları otomatik olarak güncelleştirecektir. Private Sub workbook_open() Link = ActiveWorkbook.LinkSources(xlExcelLinks) If IsEmpty(Link) = False Then For a = 1 To UBound(Link) Workbooks.Open Link(a), Password:="9876", WriteResPassword:="9876" ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources ActiveWorkbook.Close False Next End If End Sub

ID : 2054
ISLEM : t.c. merkez bankası güncel döviz kurlarını alma
MAKRO KODU : ‘Microsoft İnternet Transfer Control, version 6.0 ı ekleyiniz. ‘C:\Windows\System32 de MSINET.OCX i ‘Bu kodlar genellikle *.html ve *.htm uzantılı sayfalarda işlem görmektedir. partner = Inet1.OpenURL("http://www.tcmb.gov.tr/kurlar/today.html") TextBox1.Text = Mid(partner, InStr(partner, "USD") + 42, 6) & " YTL" ' USD adlı kelimeyi bulur ve 42. karakterden itibaren 6 karakter sağındakine kadar TextBox1 e aktarır. ‘Aşağıdakileri de bu şekilde yorumlayabilirsiniz. TextBox2.Text = Mid(partner, InStr(partner, "USD") + 55, 6) & " YTL" TextBox3.Text = Mid(partner, InStr(partner, "EUR") + 42, 6) & " YTL" TextBox4.Text = Mid(partner, InStr(partner, "EUR") + 55, 6) & " YTL"

ID : 2055
ISLEM : tab ile textbox içeriğini seçme
MAKRO KODU : Private Sub TextBox2_Enter() Me.TextBox2.EnterFieldBehavior = fmEnterFieldBehaviorRecallSelection End Sub

ID : 2056
ISLEM : tab ile textbox içeriğini seçme 2
MAKRO KODU : Private Sub TextBox2_Enter() Me.TextBox2.EnterFieldBehavior = fmEnterFieldBehaviorSelectAll End Sub

ID : 2057
ISLEM : tablo boşaltır
MAKRO KODU : YENİ VERİ GİRMEK İÇİN TABLOYU BOŞALTIR Private Sub CommandButton5_Click() Unload Günlük Günlük.Show End Sub 'TABLOYU TEMİZLE Private Sub CommandButton10_Click() ComboBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" ComboBox1.SetFocus End Sub

ID : 2058
ISLEM : tablo boşaltir
MAKRO KODU : YENİ VERİ GİRMEK İÇİN TABLOYU BOŞALTIR Private Sub CommandButton5_Click() Unload Günlük Günlük.Show End Sub 'TABLOYU TEMİZLE Private Sub CommandButton10_Click() ComboBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" ComboBox1.SetFocus End Sub

ID : 2059
ISLEM : tablonuz açıldığı anda internettesiniz:
MAKRO KODU : Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate "http://www.mynet.com" End Sub

ID : 2060
ISLEM : tablonuz açildiği anda
MAKRO KODU : Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate "http://www.excel.web.tr" End Sub

ID : 2061
ISLEM : tablonuzu tam ekran yapar
MAKRO KODU : Makro bölümüne yapıştırın ve tuşa atayın Tam ekran için Kod: Sub tam() Application.DisplayFullScreen = True End Sub Normal görünüm için Kod: Sub normal() Application.DisplayFullScreen = False End Sub

ID : 2062
ISLEM : takvimi sayfaya yazar(yılı değiştiriniz)
MAKRO KODU : Sub takvim() Dim varYear As Variant Dim bytMonth As Byte Dim bytDay As Byte Dim bytWeekday As Byte Dim strWeekday As String Dim ws As Worksheet varYear = 2005 For Each ws In Worksheets If ws.Name = "Jahr " & varYear Then ws.Delete End If Next ws Set ws = Worksheets.Add ws.Name = "Jahr " & varYear For bytMonth = 1 To 12 With Cells(1, bytMonth) .Value = Format(DateSerial(varYear, bytMonth, 1), "mmmm") .Interior.ColorIndex = 36 .Font.Bold = True End With For bytDay = 1 To Day(DateSerial(varYear, bytMonth + 1, 0)) With Cells(bytDay + 1, bytMonth) bytWeekday = Weekday(DateSerial(varYear, bytMonth, bytDay)) strWeekday = WhichWeekday(bytWeekday) .Value = strWeekday & ", " & bytDay If bytWeekday = 7 Or bytWeekday = 1 Then .Interior.ColorIndex = 22 End If End With Next bytDay Next bytMonth End Sub Function WhichWeekday(ByVal bytWeekday As Byte) As String Select Case bytWeekday Case 1 WhichWeekday = "pazar" Case 2 WhichWeekday = "p.tesi" Case 3 WhichWeekday = "salı" Case 4 WhichWeekday = "carsamba" Case 5 WhichWeekday = "persembe" Case 6 WhichWeekday = "cuma" Case 7 WhichWeekday = "c.tesi" End Select End Function

ID : 2063
ISLEM : tam dizin ismini veren bir kod
MAKRO KODU : Sub Tam_Dizin_İsmi() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.GetAbsolutePathName("") MsgBox a End Sub

ID : 2064
ISLEM : tam ekran için
MAKRO KODU : Sub tam() Application.DisplayFullScreen = True End Sub

ID : 2065
ISLEM : tam ekran normal ekran
MAKRO KODU : EKRANI BÜYÜLTÜR Sub Auto_Open() Sheets("kitap1").Select Application.DisplayFullScreen = True Application.DisplayFormulaBar = False Application.DisplayFormulaBar = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False End With Range("A1").Select End Sub EKARNI KÜÇÜLTÜR Sub Auto_Close() Sheets("kitap1").Select Application.DisplayFullScreen = False Application.DisplayFormulaBar = True With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True End With End Sub

ID : 2066
ISLEM : tam ekran normal ekran
MAKRO KODU : EKRANI BÜYÜLTÜR Sub Auto_Open() Sheets("kitap1").Select Application.DisplayFullScreen = True Application.DisplayFormulaBar = False Application.DisplayFormulaBar = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False End With Range("A1").Select End Sub EKARNI KÜÇÜLTÜR Sub Auto_Close() Sheets("kitap1").Select Application.DisplayFullScreen = False Application.DisplayFormulaBar = True With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True End With End Sub

ID : 2067
ISLEM : tam ekran userform
MAKRO KODU : Private Sub UserForm_Activate() Me.Top = Application.Top Me.Left = Application.Left Me.Height = Application.Height Me.Width = Application.Width End Sub

ID : 2068
ISLEM : tam ekran yap, ve çubuğu gizle
MAKRO KODU : Application.DisplayFullScreen = True Application.CommandBars("Full Screen").Enabled = False

ID : 2069
ISLEM : tanımlı adları silme
MAKRO KODU : Sub name_delete() Dim definedName As Object For Each definedName In ActiveWorkbook.Names definedName.Delete Next End Sub

ID : 2070
ISLEM : tarih formati yanliş ise uyarsin.
MAKRO KODU : Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox1.Value <> "" And IsDate(TextBox1.Value) = False Then MsgBox ("hatalı veri girişi" & vbCrLf & TextBox1) TextBox1.Value = "" Else TextBox1 = Format(TextBox1, "dd.mm.yyyy") End If End Sub