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


şarta göre mesajbox görüntüleme

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] -

şartlara göre aktif yada pasif olan komut düğmesi

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.

şartlı wav çaldırma

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

şekillerin alanlarını hesaplama

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

şıfreleme de son nokta

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.

şıfreli giriş 0-254 arası bir sayı

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 -

şıfreli giriş userformda textboxlu

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 -

şıfreli yazıyı deşifre etme

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 -

şıfreyi girince kodlar tekrar aktif olsun

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" -

şıfreyi girmeye zorlama girince diğer sayfaya yönlendirir

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 "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 -

şifre açma

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

şifrelemede son nokta

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.

şifreli kapali bir dosyadan veri almak

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

t.c. merkez bankası güncel döviz kurlarını alma

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"

tab ile textbox içeriğini seçme

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

tab ile textbox içeriğini seçme 2

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

tablo boşaltır

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

tablo boşaltir

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

tablonuz açıldığı anda internettesiniz:

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

tablonuz açildiği anda

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

tablonuzu tam ekran yapar

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

takvimi sayfaya yazar(yılı değiştiriniz)

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

tam dizin ismini veren bir kod

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

tam ekran için

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

tam ekran normal ekran

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

tam ekran normal ekran

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

tam ekran userform

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

tam ekran yap, ve çubuğu gizle

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

tanımlı adları silme

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

tarih formati yanliş ise uyarsin.

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 -

* Görseller ve İçerik tekif hakkına sahip olabilir