Makro Kod Listesi

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

ID : 301
ISLEM : aktif sayfaya göre ayrı ayrı makro çalıştırma
MAKRO KODU : Private Sub CommandButton1_Click() Select Case ActiveSheet.Name Case "Sheet1" Makro1 Case "Sheet2" Makro2 Case "Sheet3" Makro3 Case Else Makro4 End Select Unload Me End Sub

ID : 302
ISLEM : aktif sayfaya koruma koyma ve kaldırma
MAKRO KODU : Sub koru() ActiveSheet.Protect Password:="pir" End Sub Sub koru_ma() ActiveSheet.Unprotect Password:="pir" End Sub

ID : 303
ISLEM : aktif sayfaya veri girilince uyarı verip veriyi siler
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If IsNumeric(Target) = False Then MsgBox "Valeur numérique obligatoire" Target.Clear Target.Select End If End Sub

ID : 304
ISLEM : aktif sayfayı aktif ay adı ve yıl ile kopyalar ve çoğaltır
MAKRO KODU : Sub Add_Sheet() Dim Sayfa As Worksheet Dim SayfaAdı As String SayfaAdı = Format(Now, "mmmm_yyyy") For Each Sayfa In Worksheets If Sayfa.Name = SayfaAdı Then MsgBox "Bu isimde bir sayfa bulunmaktadır." Exit Sub End If Next Sayfa Sheets.Add.Name = SayfaAdı Sheets(SayfaAdı).Move After:=Sheets(Sheets.Count) Sheets("Sayfa1").Range("A:IV").Copy _ Sheets(SayfaAdı).Range("A1") End Sub

ID : 305
ISLEM : aktif sayfayı emaille gönderme
MAKRO KODU : Sub Mail_ActiveSheet_TXT_File() Dim wb As Workbook Dim strdate As String Dim Fname As String strdate = Format(Now, "dd-mm-yy h-mm-ss") Fname = "C:\Part of " & ThisWorkbook.Name _ & " " & strdate & ".txt" Application.ScreenUpdating = False ActiveSheet.Copy Set wb = ActiveWorkbook With wb .SaveAs Fname, FileFormat:=xlText .SendMail "kubilay_karabulut@hotmail.com", _ "Bu mail excel uzerinden geliyor" .Close False End With Kill Fname Application.ScreenUpdating = True End Sub

ID : 306
ISLEM : aktif sayfayı kopyala ve yeni bir çalışma kitabı aç ve ismini "yenisayfa" ver ve kopyalananı yapıştır:
MAKRO KODU : Sub YeniKitap() Dim Sh As Worksheet Set Sh = ActiveSheet3422 ActiveSheet.Copy ActiveSheet.Name = "YeniSayfa" Sh.Range("A1:Z10").Copy Range("A2") End Sub

ID : 307
ISLEM : aktif sayfayı kopyalar email ile yollar
MAKRO KODU : Sub EmailSheet() On Error GoTo Terminator Application.Calculation = xlCalculationManual Dim shtName As String shtName = ActiveSheet.Name ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=Application.GetSaveAsFilename("Kopya " & shtName, "Microsoft Excel File, *.xls") Application.DisplayAlerts = False Application.Dialogs(xlDialogSendMail).Show With ActiveWorkbook .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With Terminator: MsgBox "Dosya gönderilemedi" Application.Calculation = xlCalculationAutomatic End Sub

ID : 308
ISLEM : aktif sayfayı uyarısız silmeve uyarıyı eski haline getirme
MAKRO KODU : Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True

ID : 309
ISLEM : aktif sayfayı yazdırır
MAKRO KODU : Private Sub CommandButton7_Click() Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Range("A1").Select End Sub

ID : 310
ISLEM : aktif sayfayı yazdırma
MAKRO KODU : Sub PrintThisSheet() ActiveSheet.PrintOut End Sub

ID : 311
ISLEM : aktif sayfayi yazdirir
MAKRO KODU : Private Sub CommandButton7_Click() Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Range("A1").Select End Sub

ID : 312
ISLEM : aktif sütunda boş olan satıra gider
MAKRO KODU : Sub der() Range("A1").Select If Cells(ActiveCell.Row + 1, ActiveCell.Column).Value <> "" Then ActiveCell.End(xlDown).Select End If End Sub

ID : 313
ISLEM : aktif varsayılan yazıcı da yazdırır
MAKRO KODU : Sub PrintToAnotherPrinter() Dim strCurrentPrinter As String strCurrentPrinter = Application.ActivePrinter ' store the current active printer On Error Resume Next ' ignore printing errors Application.ActivePrinter = "microsoft fax on fax:" ' change to another printer ActiveSheet.PrintOut ' print the active sheet Application.ActivePrinter = strCurrentPrinter ' change back to the original printer On Error GoTo 0 ' resume normal error handling End Sub

ID : 314
ISLEM : aktif ve aktif olmayan kitapların kapatılması
MAKRO KODU : Eğer birden daha fazla Workbook açıksa sadece Active olan Window'u kapatıyoruz. Eğer tek br window (yani üzerinde çalıştığımız) açıksa tüm Excel uygulamasını kapatıyoruz. Açık olan pencereleri sayıyor ve eğer tek bir window açıksa Exceli kapatıyor. 'Değilse sadece o pencereyi kapatıyor. If Application.Windows.Count = 1 Then Application.Quit Else Application.ActiveWindow.Close End If

ID : 315
ISLEM : aktif ve dolu hücreler arasına kaç boş satır eklensin
MAKRO KODU : Sub SpreadOut() Dim bossat As Integer, J As Integer bossat = InputBox("Kaç satır Olacak?", "Boş Satır Ekle") ActiveCell.Offset(1, 0).Select While ActiveCell.Value > "" And bossat > 0 For J = 1 To bossat Selection.EntireRow.Insert Next J ActiveCell.Offset(bossat + 1, 0).Select Wend End Sub

ID : 316
ISLEM : aktif yazıcının ismini öğrenme
MAKRO KODU : Sub ActivePrinter_() 'Aktif Yazacınızı ismini öğrenin MsgBox ActivePrinter End Sub

ID : 317
ISLEM : aktifa sayfada otomatik filtreleme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) ActiveCell.EntireColumn.AutoFit ActiveCell.EntireRow.AutoFit End Sub

ID : 318
ISLEM : aktşf sayfada rectangle (dörtgen) silmek
MAKRO KODU : Sub dortgen_sil() For Each Rectangle In ActiveSheet.Shapes Rectangle.Delete Next End Sub

ID : 319
ISLEM : alarmlı saat
MAKRO KODU : Sub Alarm() Dim beepat As String beepat = InputBox("Give Alarm at", "hh:mm:ss " & _ Format(Now, "mm:hh"), "17:00") If beepat = "" Then MsgBox "cancelled" Exit Sub End If Application.OnTime TimeValue(beepat), "BeepMe" End Sub 'Example of a Count Down Timer Sub CountDownTimer() Dim beepat As String beepat = InputBox("Count down Timer hh:mm:ss i.e. 10:00", _ "Time now is " & Format(Now, "hh:mm:ss"), "3:00") If beepat = "" Then MsgBox "cancelled" Exit Sub End If Application.OnTime (Now + TimeValue(beepat)), "BeepMe" End Sub Sub beepme() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), "beepme2" End Sub Sub beepme2() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), "beepme3" End Sub Sub beepme3() Beep End Sub

ID : 320
ISLEM : alt alta kaydetme ve alfabetik sıralama
MAKRO KODU : Private Sub CommandButton1_Click() ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate Row = ActiveCell.Row + 1 Cells(Row, 1).Activate ActiveCell.Offset(0, 0).Value = TextBox1.Text ActiveCell.Offset(0, 1).Value = TextBox2.Text ActiveCell.Offset(0, 2).Value = TextBox3.Text ActiveCell.Offset(0, 3).Value = TextBox4.Text Range("A3:D3030").Select Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Dim i As Integer For i = 0 To GELEN.Controls.Count - 1 If Mid(GELEN.Controls(i).Name, 1, 7) = "TextBox" Then GELEN.Controls(i).Value = "" DoEvents End If Next i End Sub

ID : 321
ISLEM : alt alta kayıt işlemi
MAKRO KODU : Private Sub CommandButton1_Click() Application.ScreenUpdating = False 'BU KOD MAKRO ÇALIŞINKEN SAYFA HAREKETLERİNİ ENGELLER If TextBox1.Value = "" Then MsgBox ("KAYIT YAPILACAK KİŞİNİN İSMİNİ GİRİNİZ.") Exit Sub Else End If 'BU KOD TEXTBOX1 E KAYIT GİRİLMEMİŞ İSE İŞLEM YAPMASINA İZİN VERMEZ. Sheets("DATA").Select Range("a2").Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop If Range("a2").Value = "" Then Range("a2").Value = 1 Else ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1 End If 'BU KODLAR DATA SAYFASINI SEÇER,KAYIT OLMAYAN SATIRI BULUR,KAYIDA OTOMATİK NUMARA VERİR. ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value ActiveCell.Offset(0, 4).Value = TextBox4.Value ActiveCell.Offset(0, 5).Value = TextBox5.Value ActiveCell.Offset(0, 6).Value = TextBox6.Value ActiveCell.Offset(0, 7).Value = TextBox7.Value ActiveCell.Offset(0, 8).Value = TextBox8.Value ActiveCell.Offset(0, 9).Value = TextBox9.Value ActiveCell.Offset(0, 10).Value = TextBox10.Value ActiveCell.Offset(0, 11).Value = TextBox11.Value ActiveCell.Offset(0, 12).Value = TextBox12.Value ActiveCell.Offset(0, 13).Value = TextBox13.Value ActiveCell.Offset(0, 14).Value = TextBox14.Value ActiveCell.Offset(0, 15).Value = TextBox15.Value ActiveCell.Offset(0, 16).Value = TextBox16.Value 'BU KODLAR TEXTBOXDAKİ BİLGİLERİ AYNI SATIRDA,FARKLI SUTUNLARA KAYIT YAPAR TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" TextBox4.Value = "" TextBox5.Value = "" TextBox6.Value = "" TextBox7.Value = "" TextBox8.Value = "" TextBox9.Value = "" TextBox10.Value = "" TextBox11.Value = "" TextBox12.Value = "" TextBox13.Value = "" TextBox14.Value = "" TextBox15.Value = "" TextBox16.Value = "" 'BU KODLAR TEXTBOXLARDAKİ VERİLERİ SİLER MsgBox ("Bilgiler veri tabanına kayıt edildi.") 'BU KOD MESAJ VERİR. Application.ScreenUpdating = True 'BU KOD SAYFA HAREKETİNİ NORMAL HALE GETİRİR. End Sub

ID : 322
ISLEM : alt klasörler
MAKRO KODU : Sub Alt_Klasör_İsmi_Al() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") f = ds.GetParentFolderName("D:\ExcelÖrnekleri\Vergi İade") MsgBox f End Sub

ID : 323
ISLEM : alt+enter kodunda nasil bir değişiklik yapabilirim.
MAKRO KODU : Sub DUZEN() For x=1 To 10 For y=1 To 10 Cells(x,y).select ActiveCell.Value = Application.WorksheetFunction.Clean(ActiveCell.Value) ActiveCell.Value = Application.WorksheetFunction.Trim(ActiveCell.Value) Next Next End Sub

ID : 324
ISLEM : altbilgide dosya yolunu yazar
MAKRO KODU : Sub Dateipfad() Worksheets(1).PageSetup.LeftFooter = ThisWorkbook.FullName End Sub

ID : 325
ISLEM : anamenu.xls açik değilse diğer workbook açilmasin
MAKRO KODU : Private Sub Workbook_Open() Dim i As Byte Dim AnaMenüAçık As Boolean For i = 1 To Workbooks.Count If Workbooks(i).Name = "Anamenü.xls" Then AnaMenüAçık = True Exit Sub Else AnaMenüAçık = False End If Next If AnaMenüAçık = False Then MsgBox "Lütfen önce AnaMenü.xls dosyasını açınız..." ThisWorkbook.Close End If End Sub

ID : 326
ISLEM : api
MAKRO KODU : Option Explicit Private Declare Function GetEnvironmentVariable Lib "kernel32" _ Alias "GetEnvironmentVariableA" ( _ ByVal lpName As String, _ ByVal lpBuffer As String, _ ByVal nSize As Long) As Long Function GetEnvironmentVar(strEnvName As String) As String GetEnvironmentVar = String(255, 0) GetEnvironmentVariable strEnvName, _ GetEnvironmentVar, _ Len(GetEnvironmentVar) If InStr(1, GetEnvironmentVar, Chr(0)) > 0 Then GetEnvironmentVar = Left(GetEnvironmentVar, _ InStr(1, GetEnvironmentVar, Chr(0)) - 1) End If GetEnvironmentVar = strEnvName & ": " & GetEnvironmentVar End Function Sub GetEnviro() Dim strMsg As String '// Build the string msg strMsg = GetEnvironmentVar("_MACH") strMsg = strMsg & vbCr & GetEnvironmentVar("_TYPE") strMsg = strMsg & vbCr & GetEnvironmentVar("ALLUSERSPROFILE") strMsg = strMsg & vbCr & GetEnvironmentVar("APPDATA") strMsg = strMsg & vbCr & GetEnvironmentVar("CommonProgramFiles") strMsg = strMsg & vbCr & GetEnvironmentVar("COMPUTERNAME") strMsg = strMsg & vbCr & GetEnvironmentVar("ComSpec") strMsg = strMsg & vbCr & GetEnvironmentVar("HOMEDRIVE") strMsg = strMsg & vbCr & GetEnvironmentVar("HOMEPATH") strMsg = strMsg & vbCr & GetEnvironmentVar("HOMESHARE") strMsg = strMsg & vbCr & GetEnvironmentVar("Include") strMsg = strMsg & vbCr & GetEnvironmentVar("Lib") strMsg = strMsg & vbCr & GetEnvironmentVar("LOGONSERVER") strMsg = strMsg & vbCr & GetEnvironmentVar("LOGSERVER") strMsg = strMsg & vbCr & GetEnvironmentVar("NUMBER_OF_PROCESSORS") strMsg = strMsg & vbCr & GetEnvironmentVar("OS") strMsg = strMsg & vbCr & GetEnvironmentVar("Os2LibPath") strMsg = strMsg & vbCr & GetEnvironmentVar("Path") strMsg = strMsg & vbCr & GetEnvironmentVar("PATHEXT") strMsg = strMsg & vbCr & GetEnvironmentVar("PROCESSOR_ARCHITECTURE") strMsg = strMsg & vbCr & GetEnvironmentVar("PROCESSOR_IDENTIFIER") strMsg = strMsg & vbCr & GetEnvironmentVar("PROCESSOR_LEVEL") strMsg = strMsg & vbCr & GetEnvironmentVar("PROCESSOR_REVISION") strMsg = strMsg & vbCr & GetEnvironmentVar("ProgramFiles") strMsg = strMsg & vbCr & GetEnvironmentVar("SMSHOME") strMsg = strMsg & vbCr & GetEnvironmentVar("STARTUPLOG") strMsg = strMsg & vbCr & GetEnvironmentVar("SYBASE") strMsg = strMsg & vbCr & GetEnvironmentVar("SystemDrive") strMsg = strMsg & vbCr & GetEnvironmentVar("SystemRoot") strMsg = strMsg & vbCr & GetEnvironmentVar("TEMP") strMsg = strMsg & vbCr & GetEnvironmentVar("TMP") strMsg = strMsg & vbCr & GetEnvironmentVar("USERDOMAIN") strMsg = strMsg & vbCr & GetEnvironmentVar("USERDOMAIN") strMsg = strMsg & vbCr & GetEnvironmentVar("UserName") strMsg = strMsg & vbCr & GetEnvironmentVar("USERPROFILE") strMsg = strMsg & vbCr & GetEnvironmentVar("windir") MsgBox strMsg, vbInformation, "Envoronmental variables" End Sub

ID : 327
ISLEM : application.ontime
MAKRO KODU : Size Bu Örnek Fikir verebilir.Kendi çalışmanıza derlersiniz. A1 Hücresine İstediğiniz zamanı atarsınız.Tabii A1 Hücresini ss:dd:nn biçimlendirmeniz gerek. Kod: Sub basla() Application.OnTime Now + [a1], procedure:="Mesaj" End Sub Sub Mesaj() MsgBox "deneme" End Sub

ID : 328
ISLEM : ara bul bulunca yan hücreye yaz
MAKRO KODU : Sub SearchText() Dim SearchString, SearchChar, MyPos SearchChar = "salut" For Each cell In Range("A1:A11") SearchString = cell.Text MyPos = InStr(SearchString, SearchChar) If MyPos > 0 Then MsgBox ("Mot trouvé") MsgBox "Mot trouvé à cette adresse: " & cell.Address cell(1, 2).Value = "(salut) est sur cette ligne" End If Next End Sub

ID : 329
ISLEM : ara bul diğer sayfaya kopyala
MAKRO KODU : Sub arabul() ara = Application.InputBox(prompt:="Aranacak Veri?", Type:=3) Range("A3:A341").Select Selection.Find(What:=ara, After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False).Activate satir = ActiveCell.Row Range(Cells(satir, 2), Cells(satir, 8)).Select Selection.Copy Sheets("Sayfa1").Select Range("A2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True End Sub

ID : 330
ISLEM : ara bul listele
MAKRO KODU : Sub Asteriks() Dim i As Integer Dim j As Integer Dim Sayac As Integer Dim SinananVeri As String Veri = InputBox("Aranan Veriyi Belirtiniz", "ARANAN VERİ", "") SinananVeri = "*" & Veri & "*" Set Say1 = Worksheets("Sayfa1") Set Say2 = Worksheets("Sayfa2") j = 1 For i = 1 To 10 If WorksheetFunction.CountIf(Say2.Cells(i, 1), SinananVeri) > 0 Then Say1.Cells(j, 1) = Say2.Cells(i, 1) Sayac = Sayac + 1 j = j + 1 End If Next i MsgBox Say2.Name & "'de aramış olduğunuz " & Veri & " verisini içeren toplam " & Sayac & " adet hücre değeri bulundu ve " & Say1.Name & "'de listelendi." End Sub