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


sistem yazıcılarını görme

ID : 1981
ISLEM : sistem yazıcılarını görme
MAKRO KODU : Sub yazlist() Shell ("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder") End Sub

siyahla yazili .. lari çiktida görünmemesi için beyaz renkli olmasini istiyorum

ID : 1982
ISLEM : siyahla yazili .. lari çiktida görünmemesi için beyaz renkli olmasini istiyorum
MAKRO KODU : Sub mt() Columns("b:b").Select Selection.Font.ColorIndex = 2 End Sub

solda, sağdan karakter sayma + kaç karakter var onu da sayar

ID : 1983
ISLEM : solda, sağdan karakter sayma + kaç karakter var onu da sayar
MAKRO KODU : Sub myEdit() MsgBox Left("abcd", 2) 'soldan 2 karakter say MsgBox Right("abcd", 2) 'sağdan 2 karakter say MsgBox Len("abcd") 'sayısal olarak karakter say End Sub

son dolu satır ve sütun

ID : 1984
ISLEM : son dolu satır ve sütun
MAKRO KODU : Sub sondolu_satir() i = ActiveSheet.UsedRange.Rows.Count MsgBox i End Sub Sub sondolu_sutun() i = ActiveSheet.UsedRange.Columns.Count MsgBox i End Sub

son yazilan sayfanin silinmesi içinde çikiş butonuna aşağidaki kodu yazin.

ID : 1985
ISLEM : son yazilan sayfanin silinmesi içinde çikiş butonuna aşağidaki kodu yazin.
MAKRO KODU : Private Sub CommandButton3_Click() Application.DisplayAlerts = False Sheets(Sheets.Count).Delete Unload Me End Sub

sözlük kodlari

ID : 1986
ISLEM : sözlük kodlari
MAKRO KODU : SÖZLÜK OLUŞTURMA KODLARI Sub auto_open() Dim cbMenu As CommandBarControl MenuSil Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With cbMenu .Caption = "&Sözlük" .OnAction = "formac" .Tag = "MyTag" .BeginGroup = True End With If cbMenu Is Nothing Then Exit Sub Set cbSubMenu = Nothing Set cbMenu = Nothing End Sub Sub MenuSil() kaldir "MyTag" End Sub Private Sub kaldir(CustomControlTag As String) On Error Resume Next Do Application.CommandBars.FindControl(, , CustomControlTag, False).Delete Loop Until Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing On Error GoTo 0 End Sub Sub auto_close() MenuSil End Sub Sub formac() UserForm1.Show End Sub SÖZLÜK OLUŞTURMA KODLARI Private Sub UserForm_Initialize() With ListBox1 .RowSource = "[Sözlük.xla]TrEng!A1:A16174" .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox1 .RowSource = "[Sözlük.xla]TrEng!A1:A16174" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox2 .RowSource = "[Sözlük.xla]TrEng!B1:B16174" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = "Verdana" .Font.Size = 10 End With With ListBox2 .RowSource = "[Sözlük.xla]EngTr!A1:A11435" .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox3 .RowSource = "[Sözlük.xla]EngTr!A1:A11435" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox4 .RowSource = "[Sözlük.xla]EngTr!B1:B11435" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = "Verdana" .Font.Size = 10 End With End Sub 'BU KOD COMBOBOX1'E YAZILACAK Private Sub ComboBox1_Change() ListBox1.ListIndex = ComboBox1.ListIndex ComboBox2.ListIndex = ComboBox1.ListIndex End Sub 'BURASI BOŞ KALACAK Private Sub ComboBox2_Change() End Sub 'BU KOD BUTTON'A YAZILACAK Private Sub CommandButton1_Click() Unload UserForm1 End Sub 'BU KOD LİSTBOX1'E YAZILACAK Private Sub ListBox1_Click() ComboBox1.ListIndex = ListBox1.ListIndex ComboBox2.ListIndex = ListBox1.ListIndex End Sub 'BU KOD FORM İÇİNE YAZILACAK Private Sub UserForm_Initialize() With ListBox1 .RowSource = "sayfa1!A1:A12174" .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox1 .RowSource = "sayfa1!A1:A12174" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = "Verdana" .Font.Size = 10 End With With ComboBox2 .RowSource = "sayfa1!B1:B12174" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = "Verdana" .Font.Size = 12 End With End Sub

spinbutton ile listbox'ta ilk ve son satira gitmek.

ID : 1987
ISLEM : spinbutton ile listbox'ta ilk ve son satira gitmek.
MAKRO KODU : visual basic kodu: -------------------------------------------------------------------------------- Private Sub SpinButton1_SpinDown() ListBox1.ListIndex = ListBox1.ListCount - 1 End Sub -------------------------------------------------------------------------------- visual basic kodu: -------------------------------------------------------------------------------- Private Sub SpinButton1_SpinUp() ListBox1.ListIndex = 0 End Sub

status barda mesajla bekleterek makro yaptırma

ID : 1988
ISLEM : status barda mesajla bekleterek makro yaptırma
MAKRO KODU : Sub RowsToColumns() Dim rCol As Range Dim rCell1 As Range, rCell2 As Range Dim i As Integer, iPBcount As Integer Dim Sht As Worksheet Application.StatusBar = "Converting, please wait....!" Application.ScreenUpdating = False 'Set range variable to Selection Set Sht = ActiveSheet Set rCol = Sht.UsedRange.Columns(1) 'Insert page breaks Sht.PageSetup.PrintArea = "" Sht.PageSetup.Zoom = 100 ActiveWindow.View = xlPageBreakPreview 'Count only horizontal page breaks and pass to an Integer iPBcount = Sht.HPageBreaks.Count On Error Resume Next 'Loop as many times as there horizontal page breaks. For i = 1 To iPBcount 'Set variable 1 to page break X Set rCell1 = Sht.HPageBreaks(i).Location 'Set variable 2 to X page break Set rCell2 = Sht.HPageBreaks(i + 1).Location.Offset(-1, 0) If rCell2 Is Nothing Then 'Last page break Range(rCell1, rCol.Cells(65536, 1).End(xlUp)).Cut Destination:=Sht.Cells(1, i + 1) Else Range(rCell1, rCell2).Cut Destination:=Sht.Cells(1, i + 1) End If Set rCell1 = Nothing Set rCell2 = Nothing Next i On Error GoTo 0 ActiveWindow.View = xlNormalView Application.ScreenUpdating = True Sht.DisplayPageBreaks = False Application.Goto rCol.Cells(1, 1), True Set rCol = Nothing Application.StatusBar = "" End Sub

statusbar da (durum çubuğunda) kayan yazı

ID : 1989
ISLEM : statusbar da (durum çubuğunda) kayan yazı
MAKRO KODU : Declare Sub Sleep Lib "kernel32" _ (ByVal dwMilliseconds As Long) Private Declare Function WaitForSingleObject Lib "kernel32" _ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) As Long Private Declare Function OpenProcess Lib "kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Const INFINITE = -1& Private Const SYNCHRONIZE = &H100000 Dim LaufbandExit As Integer Sub LaufbandStart() Dim OrStatus As String Dim LaufText As String Dim B As Range Dim BZelle As Range LaufbandExit = 0 OrStatus = Application.DisplayStatusBar Application.DisplayStatusBar = True Set B = Sheets("Lauftext").Range("A1:D10") LaufText = String(130, " ") For Each BZelle In Sheets("Lauftext").Range("A1:D10") LaufText = LaufText & " " & BZelle.Text Next BZelle Application.StatusBar = LaufText Do Sleep 100 'Verzögerung in Millisekunden LaufText = Right(LaufText, Len(LaufText) - 1) & Left(LaufText, 1) Application.StatusBar = LaufText DoEvents If LaufbandExit = 1 Then Application.StatusBar = False Application.DisplayStatusBar = OrStatus LaufbandExit = 0 Exit Sub End If Loop End Sub Sub LaufbandEnde() LaufbandExit = 1 End Sub

statusbar da 10 dan geriye doğru say ve mesaj ver

ID : 1990
ISLEM : statusbar da 10 dan geriye doğru say ve mesaj ver
MAKRO KODU : Option Explicit Sub Countdown() Dim intCounter As Integer Dim bln As Boolean bln = Application.DisplayStatusBar For intCounter = 10 To 1 Step -1 Application.StatusBar = "Noch " & _ intCounter & " Sekunden ..." Application.Wait Now + TimeSerial(0, 0, 1) Next intCounter Application.StatusBar = False Application.DisplayStatusBar = bln MsgBox "Fertig ", vbOKOnly, "© K.-M. Buss" End Sub

statusbar da mükemmel ınitialize

ID : 1991
ISLEM : statusbar da mükemmel ınitialize
MAKRO KODU : Sub Fortschritt() Dim i%, y% For i = 1 To 10 StatusLED "İşlem Yapılıyor: ", i / 10 Application.Wait Now + TimeSerial(0, 0, 1) Next i End Sub Function StatusLED(Msg As String, Pct As Single) Dim PctDone As Integer Dim NumReps As Integer With Application PctDone = .Round(Pct, 2) * 100 NumReps = Int(PctDone / 5) .StatusBar = Msg & .Rept(Chr(14), NumReps) & _ .Rept("**", 20 - NumReps) & " " & PctDone & "%" End With End Function

statusbar(durum çubuğu) da saniyeli mesaj

ID : 1992
ISLEM : statusbar(durum çubuğu) da saniyeli mesaj
MAKRO KODU : Sub StatusBarExample() Application.ScreenUpdating = False Application.DisplayStatusBar = True Application.StatusBar = "Please wait while performing task 1..." ' add some code for task 1 that replaces the next sentence Application.Wait Now + TimeValue("00:00:02") Application.StatusBar = "Please wait while performing task 2..." ' add some code for task 2 that replaces the next sentence Application.Wait Now + TimeValue("00:00:02") Application.StatusBar = False End Sub

statusbar1 saat gösterme

ID : 1993
ISLEM : statusbar1 saat gösterme
MAKRO KODU : Private Sub UserForm_Activate() Do DoEvents StatusBar1.Panels(1).Text = Time Loop End Sub ' Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) End End Sub

stil penceresi

ID : 1994
ISLEM : stil penceresi
MAKRO KODU : Sub Dialog_05() Application.Dialogs(xlDialogApplyStyle).Show End Sub Sub Dialog_21() Application.Dialogs(xlDialogDefineStyle).Show End Sub

sub dosyabul()

ID : 1995
ISLEM : sub dosyabul()
MAKRO KODU : sub dosyabul() dim a as string a = application.findfile msgbox a end sub

sutun seçimini makrodaki ("c:c") değeriyle oynayarak değiştirebilirsiniz

ID : 1996
ISLEM : sutun seçimini makrodaki ("c:c") değeriyle oynayarak değiştirebilirsiniz
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns("C:C") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub

sutun seçimini makrodaki ("c:c") değeriyle oynayarak değiştirebilirsiniz

ID : 1997
ISLEM : sutun seçimini makrodaki ("c:c") değeriyle oynayarak değiştirebilirsiniz
MAKRO KODU : Sutun seçimini makrodaki ("C:C") değeriyle oynayarak değiştirebilirsiniz örnek:("E:E") veya ("A:A") Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns("C:C") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub

sutunu ve aranacak değer makronun içine yazılır

ID : 1998
ISLEM : sutunu ve aranacak değer makronun içine yazılır
MAKRO KODU : Sub bul() Dim cell As Range i = 0 For Each cell In Sheets("Sayfa1").Range("B1:B" & Range("B65536").End(xlUp).Row) i = i + 1 If cell = "kubilay" Then cell.Offset(0, 1) = "bulundu" End If Debug.Print i Next cell End Sub

süre sona erdirme

ID : 1999
ISLEM : süre sona erdirme
MAKRO KODU : Application.Visible = False Dim d, x, y d = GetSetting("DANISMAN", "Ayarlar", "Ilk Giris", "") If d = "" Then SaveSetting "DANISMAN", "Ayarlar", "Ilk Giris", Date Else If (Date - CDate(d)) > 365 Then MsgBox ("Programin Demo Süresi dolmustur.") DoCmd.Close Application.Quit Else x = GetSetting("DANISMAN", "Ayarlar", "Son Çikis Tarihi", "") If x = "" Then 'End Else If CVDate(x) > Date Then MsgBox ("Programin Deneme Süresi Doldu Lütfen Israr Etmeyin") DoCmd.Close Else y = GetSetting("DANISMAN", "Ayarlar", "Son Çikis Saati", "") If (CVDate(x) = Date) And (CVDate(y) > Time) Then MsgBox ("Programin Deneme Süresi Doldu Lütfen Israr Etmeyin") DoCmd.Close End If End If x = GetSetting("DANISMAN", "Ayarlar", "Sayi", "1") MsgBox ("Programi" & x & ". defa çalistiriyorsunuz.") SaveSetting "DANISMAN", "Ayarlar", "Sayi", x + 1 End If End If End If siparisfrm.Show Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) SaveSetting "DANISMAN", "Ayarlar", "Son Çikis Tarihi", Date SaveSetting "DANISMAN", "Ayarlar", "Son Çikis Saati", Time Application.Visible = True Application.Quit End Sub

sürekli flash veren makro örneği

ID : 2000
ISLEM : sürekli flash veren makro örneği
MAKRO KODU : Dim NextTime As Date Sub Flash() NextTime = Now + TimeValue("00:00:01") With ActiveWorkbook.Styles("Flash").Font If .ColorIndex = 2 Then .ColorIndex = 3 Else .ColorIndex = 2 End With Application.OnTime NextTime, "Flash" End Sub Sub StopIt() Application.OnTime NextTime, "Flash", schedule:=False ActiveWorkbook.Styles("Flash").Font.ColorIndex = xlAutomatic End Sub

süreli userform

ID : 2001
ISLEM : süreli userform
MAKRO KODU : Private Sub UserForm_Activate() Dim Pausenlänge, Start, Ende, Gesamtdauer Pausenlänge = 10 ' Dauer festlegen. Start = Timer ' Anfangszeit setzen. UserForm1.Caption = "http://www.excel-lex.de.vu © 2003 K.-M. Buss" Do While Timer -

süreli userform 1

ID : 2002
ISLEM : süreli userform 1
MAKRO KODU : Private Sub UserForm_Activate() ' Récupération de l'heure d'affichage de la BdD TimeDebut = Timer ' Donne la main à excel pour facilité l'affichage de la BdD DoEvents ' Boucle tant que 2 secondes ne se sont pas écoulé While Timer -

süreli userform 2

ID : 2003
ISLEM : süreli userform 2
MAKRO KODU : Private Sub UserForm_Activate() Application.Wait Now + TimeSerial(0, 0, 3) Unload Me End Sub

sürücü seri numarası göster

ID : 2004
ISLEM : sürücü seri numarası göster
MAKRO KODU : Sub Sürücü_Seri_Numarası_Göster() On Error GoTo hata: Dim ds, d, s, t Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive("C:\") Select Case d.DriveType Case 0: t = "Bilinmiyor" Case 1: t = "Çıkarılabilir" Case 2: t = "HardDisk" Case 3: t = "Ağ" Case 4: t = "CD-ROM" Case 5: t = "RAM Disk" End Select s = "Sürücü " & d.DriveLetter & ": " & t If d.IsReady Then s = s & vbCrLf & d.SerialNumber MsgBox s Else s = s & vbCrLf & "Sürücü Hazır Değil." MsgBox s End If End hata: MsgBox "Böyle Bir Sürücü Yok" End Sub

sürücü1) sürücünün olup olmadığını arama

ID : 2005
ISLEM : sürücü1) sürücünün olup olmadığını arama
MAKRO KODU : Sub Sürücü_ara() Set ds = CreateObject("Scripting.FileSystemObject") a = ds.DriveExists("Ğ:\") If a = True Then MsgBox "Bu isimde bir sürücü var" Else MsgBox "Bu isimde bir sürücü yok" End If End Sub

sürücü2) sürücü kaç tane acaba

ID : 2006
ISLEM : sürücü2) sürücü kaç tane acaba
MAKRO KODU : Sub Sürücü_Sayısı() Dim ds, dc, s Set ds = CreateObject("Scripting.FileSystemObject") Set dc = ds.Drives s = dc.Count MsgBox s End Sub

sürücü3) sürücü isimlerini öğrenmek için

ID : 2007
ISLEM : sürücü3) sürücü isimlerini öğrenmek için
MAKRO KODU : Sub Sürücü_İsimleri() Dim ds, dc, s Set ds = CreateObject("Scripting.FileSystemObject") Set dc = ds.Drives For Each sürücü In dc s = s & vbCrLf & sürücü Next MsgBox s End Sub

sürücü4) sürücü harfi göster

ID : 2008
ISLEM : sürücü4) sürücü harfi göster
MAKRO KODU : Sub Sürücü_Harfi_Göster() Dim ds, d, s Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive("C:\") s = d.DriveLetter MsgBox s End Sub

sürücü6) boş alan göster

ID : 2009
ISLEM : sürücü6) boş alan göster
MAKRO KODU : Sub Boş_Alan_Göster() Dim ds, d, s Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive(ds.GetDriveName("C:\")) s = UCase(d) & " Sürücüsünde Boş Alan:" & Chr(13) _ + vbCrLf & FormatNumber(d.AvailableSpace) s = s & " Bytes" MsgBox s End Sub

sürücü7) sürücü hazır mı göster

ID : 2010
ISLEM : sürücü7) sürücü hazır mı göster
MAKRO KODU : Sub Sürücü_Hazır_Mı_Göster() On Error GoTo hata: Dim ds, d, s, t Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive("F:\") Select Case d.DriveType Case 0: t = "Bilinmiyor" Case 1: t = "Çıkarılabilir" Case 2: t = "HardDisk" Case 3: t = "Ağ" Case 4: t = "CD-ROM" Case 5: t = "RAM Disk" End Select s = "Sürücü " & d.DriveLetter & ": " & t If d.IsReady Then s = s & vbCrLf & "Sürücü Hazır." Else s = s & vbCrLf & "Sürücü Hazır Değil." End If MsgBox s End hata: MsgBox "Böyle Bir Sürücü Yok" End Sub

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