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


word belgesi açma

ID : 2461
ISLEM : word belgesi açma
MAKRO KODU : Sub OuvreWord() MyAppID = Shell("Winword.EXE C:\test.doc", 1) AppActivate MyAppID End Sub 'MyAppID = Shell("Winword.EXE ""C:\Mes documents\test.doc""", 1)

word de fontlar

ID : 2462
ISLEM : word de fontlar
MAKRO KODU : Sub ShowInstalledFonts() Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer Dim stdFont As String fontSize = 0 fontSize = InputBox("Enter Sample Font Size Between 8 And 30", _ "Select Sample Font Size", 12) If fontSize = 0 Then Exit Sub If fontSize 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728) If FontNamesCtrl Is Nothing Then Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _ msoBarFloating, False, True) Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728) End If Application.ScreenUpdating = False fontCount = FontNamesCtrl.ListCount Documents.Add stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name ' add heading With ActiveDocument.Paragraphs(1).Range .Text = "Installed fonts:" End With LS 2 ' list font names and font example on every other line For i = 0 To FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List(i + 1) If i Mod 5 = 0 Then Application.StatusBar = "Listing font " & _ Format(i / (fontCount - 1), "0 %") & " " & _ fontName & "..." With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = fontName .Font.Name = stdFont End With LS 1 tFormula = "abcdefghijklmnopqrstuvwxyz" If Application.International(wdProductLanguageID) = 47 Then tFormula = tFormula & "æøå" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & "1234567890" With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = tFormula .Font.Name = fontName End With LS 2 Next i ActiveDocument.Content.Font.Size = fontSize Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ActiveDocument.Saved = True Application.ScreenUpdating = True Application.ScreenRefresh End Sub Private Sub LS(lCount As Integer) ' adds lCount new paragraph(s) at the end of the document Dim i As Integer With ActiveDocument.Content For i = 1 To lCount .InsertParagraphAfter Next i End With End Sub -

word sayfasi olarak çikti almak

ID : 2463
ISLEM : word sayfasi olarak çikti almak
MAKRO KODU : Sub WordAc() fName = Application.InputBox("Dosya ismi girin...", "Dosya") If fName 0 Then ActiveSheet.Name = fName Range("A1:E25").Copy Set objword = CreateObject("Word.Application") objword.Visible = True Set MyDoc = objword.Documents.Add(DocumentType:=wdNewBlankDocument) objword.Selection.PasteSpecial Link:=False, DataType:=10 objword.activedocument.SaveAs "C:\" & fName & ".doc" End If End Sub excelden worde aktarma yapılıyor ama ben worde text olarak yapıştırmak istiyorum ki word biçimlendirmelerini yapabileyim.yani obje olarak değil metin olarak aktarabilirmiyim '************************* DataType:=10 Yukarıdaki data tipini aşağıdaki ile değiştirin. DataType:=2 -

worde veri aktarma

ID : 2464
ISLEM : worde veri aktarma
MAKRO KODU : Sub worde() fName = Application.InputBox("Dosya ismi girin...", "Dosya") If fName 0 Then ActiveSheet.Name = fName f = InputBox("Kaçıncı Satıra Kadar Aktarsın?", "Aktarılacak Bölge") Range("A1: ı" & f).Copy Set objword = CreateObject("Word.Application") objword.Visible = True Set MyDoc = objword.Documents.Add(DocumentType:=wdNewBlankDocu ment) objword.Selection.PasteSpecial Link:=False, DataType:=2 objword.activedocument.SaveAs "C:\" & fName & ".doc" End If Application.CutCopyMode = False End Sub -

wordpad'a yazdırmak istediğiniz bir metni excel içerisinden yazdırmak için

ID : 2465
ISLEM : wordpad'a yazdırmak istediğiniz bir metni excel içerisinden yazdırmak için
MAKRO KODU : Private Sub Workbook_Open() wpad = Shell("C:\Program Files\Windows NT\Accessories\wordpad.exe", vbNormalFocus) SendKeys "Excelden başka programa yazdırabiliyorum", True SendKeys "{enter}" SendKeys "Excel 'i {tab}Seviyorum", True SendKeys "{enter}" SendKeys "Yaşasınnnn!!!!", True End Sub Hatta kodun sonuna printout yazıp yazıcı çıktısı da alınabilir. Bu kodu fikirlerinizle daha da geliştirip harikalar yaratabilirsiniz. SendKeys Tuş Kodlarından Bazıları Backspace = {bksp} caps lock = {capslock} num lock = {numlock} scroll lock = {scrolllock} insert = {ins} delete = {del} end = {end} home = {home} page up = {pgup} page down= {pgdn} sağ ok = {right} sol ok = {left} alt ok = {down} üst ok = {up} tab = {tab} F1 = {F1} F2 = {F2} F3 .....

workarea1 isimli hücreyi 0 yapar

ID : 2466
ISLEM : workarea1 isimli hücreyi 0 yapar
MAKRO KODU : Sub ResetValuesToZero2() For Each n In Worksheets("Mahmut").Range("WorkArea1") n.Value = 0 End If Next n End Sub

workbook ta yazdırma komutu

ID : 2467
ISLEM : workbook ta yazdırma komutu
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) 'J.E. McGimpsey http://www.mcgimpsey.com/excel/noprintrange.html Dim vFontArr As Variant Dim oWkSht As Worksheet Dim rNoPrintRange As Range Dim rCell As Range Dim rArea As Range Dim i As Long Dim bOldScreenUpdating As Boolean Cancel = True With Application .EnableEvents = False bOldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With For Each oWkSht In ActiveWindow.SelectedSheets On Error Resume Next Set rNoPrintRange = oWkSht.Range("NoPrintRange") On Error GoTo 0 If Not rNoPrintRange Is Nothing Then With rNoPrintRange ReDim vFontArr(1 To .Count) i = 1 For Each rArea In .Areas For Each rCell In rArea With rCell vFontArr(i) = .Font.ColorIndex If .Interior.ColorIndex = xlColorIndexNone Then .Font.Color = RGB(255, 255, 255) 'white Else .Font.ColorIndex = .Interior.ColorIndex End If i = i + 1 End With Next rCell Next rArea oWkSht.PrintOut i = 1 For Each rArea In .Areas For Each rCell In rArea rCell.Font.ColorIndex = vFontArr(i) i = i + 1 Next rCell Next rArea End With Else oWkSht.PrintOut End If Set rNoPrintRange = Nothing Next oWkSht With Application .ScreenUpdating = bOldScreenUpdating .EnableEvents = True End With End Sub

workbook_addininstall

ID : 2468
ISLEM : workbook_addininstall
MAKRO KODU : Private Sub Workbook_AddinInstall() CmdNommer End Sub Private Sub Workbook_AddinUninstall() DelNommer End Sub Public Const Nommer = "Définir un nom..." Sub CmdNommer() Dim cBar As CommandBar, Ctrl As CommandBarButton Set cBar = Application.CommandBars("Cell") Set Ctrl = cBar.Controls.Add(msoControlButton, ID:=878, before:=1) With Ctrl .Caption = Nommer .FaceId = 1838 .Style = msoButtonIconAndCaption End With End Sub Sub DelNommer() On Error Resume Next Application.CommandBars("Cell").Controls(Nommer).Delete End Sub

x şeklinde uyari penceresi

ID : 2469
ISLEM : x şeklinde uyari penceresi
MAKRO KODU : X şeklinde uyarı penceresi Kod: Sub auto_open() Beep MsgBox "Mesaj Buraya!!", vbCritical, "Önemli" End Sub

xla dosyasındaki eklenti disable etmek

ID : 2470
ISLEM : xla dosyasındaki eklenti disable etmek
MAKRO KODU : Sub Test() Workbooks("pirsa.xla").IsAddin = False End Sub

xls dosyaları okuyup içinden veri almak için

ID : 2471
ISLEM : xls dosyaları okuyup içinden veri almak için
MAKRO KODU : z = "C:\belgelerim\" Set fs = Application.FileSearch With fs .LookIn = z .Filename = "*.xls" If .Execute(SortBy:=msoSortByFileName, _ SortOrder:=msoSortOrderAscending) > 0 Then MsgBox "Toplam " & .FoundFiles.Count & _ " dosya bulundu." For I = 1 To .FoundFiles.Count ' MsgBox .FoundFiles(i) A$ = .FoundFiles(I) Next I Else MsgBox "Belirtilen Klasörde Herhangi Bir Dosya Bulunamadı." End If End With

yalniz çalişma sayfasi kaydetme

ID : 2472
ISLEM : yalniz çalişma sayfasi kaydetme
MAKRO KODU : Aşağıdaki kodu deneyin. Bu kod active sayfayı yeni bir dosyaya aktarır ve o dosyayı açık olan dosyanızın bulunduğu klasöre kaydedip kapatır. Sub kopyala() ad = ActiveWorkbook.Name adr = ActiveWorkbook.Path Workbooks.Add ad2 = ActiveWorkbook.Name Set s1 = Workbooks(ad2) Workbooks(ad).Activate ActiveSheet.Copy after:=s1.Sheets(s1.Sheets.Count) For a = 1 To s1.Sheets.Count - 1 Application.DisplayAlerts = False s1.Sheets(1).Delete Next s1.SaveAs Filename:=adr & "\" & s1.Name & ".xls" s1.Close End Sub

yanıp sönme

ID : 2473
ISLEM : yanıp sönme
MAKRO KODU : Sub FlashFont() 'Joe Was 'Make cell range font flash, x times, x fast, in x color, 'when Ctrl-z is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range font flash! Set myCell = Range("A1:AF12") Application.DisplayStatusBar = True Application.StatusBar = "... Şu an flash yazı gösterisi var lütfen biraz bekleyin...! " 'Make cell font flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 3 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.3 'Make cell flash, this many times! Do Until x = 15 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = xlAutomatic Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub Sub reSetFlash() 'Re-set cell range color if edit break on color, Ctrl-r to re-set! ActiveCell.Select Selection.Interior.ColorIndex = xlNone End Sub

yanıp sönme efekti

ID : 2474
ISLEM : yanıp sönme efekti
MAKRO KODU : Sub CheckRng() If Range("B1") -

yapilan kaydi hafizada tutma

ID : 2475
ISLEM : yapilan kaydi hafizada tutma
MAKRO KODU : Alıntı: For i = 1 To 10 ComboBox1.AddItem i Next i ile combobox ın içini 1 den 10 kadar doldurdum. combobox ın değeri değiştiği an ilgili satırdan değerleri textboxlara alı aşağıdaki gibi yaptım. Alıntı: Private Sub ComboBox1_Change() TextBox1.Text = Sheets("sayfa1").Cells(4 + ComboBox1, 2) TextBox2.Text = Sheets("sayfa1").Cells(4 + ComboBox1, 3) TextBox3.Text = Sheets("sayfa1").Cells(4 + ComboBox1, 4) End Sub yukarıdaki 4 + ComboBox1 deki 4 seini verilerin 5. satırdan itibaren başladığı için eklendi. kaydete basıldığında ilgili satırdaki değişikleri yapta aşağıdaki şekilde. Alıntı: Private Sub CommandButton1_Click() Sheets("sayfa1").Cells(4 + ComboBox1, 2) = TextBox1.Text Sheets("sayfa1").Cells(4 + ComboBox1, 3) = TextBox2.Text Sheets("sayfa1").Cells(4 + ComboBox1, 4) = TextBox3.Text Sheets("sayfa1").Cells(4 + ComboBox1, 5) = TextBox2.Text * TextBox3.Text End Sub yukarıdaki 4 lerin sebebini yukarıda söyledim.

yaş bulma yıl, ay, gün olarak

ID : 2476
ISLEM : yaş bulma yıl, ay, gün olarak
MAKRO KODU : Function yas(dogum) On Error GoTo son Dim yil, ay, gun As Integer tarih = Date If dogum "" Then dogum = CDate(dogum) If dogum = "" Then yas = "": GoTo son: If dogum > tarih Then yas = "": GoTo son 'yil hesaplama yil = Year(tarih) - Year(dogum) If Month(tarih) 0 Then yas = "Hata" End Function -

yaş hesaplama

ID : 2477
ISLEM : yaş hesaplama
MAKRO KODU : Function Yaş(DogumTarihi As Date) If DogumTarihi = 0 Then Yaş = "Tarih Girmediniz" Else Select Case Month(Date) Case Is = Day(DogumTarihi) Then Yaş = Year(Date) - Year(DogumTarihi) Else Yaş = Year(Date) - Year(DogumTarihi) - 1 End If Case Is > Month(DogumTarihi) Yaş = Year(Date) - Year(DogumTarihi) End Select End If End Function bu fonksiyona göre doğum tarihinin a1 hücresinde olduğunu varsayarsak formül şu şekilde olacak =Yaş(A1) -

yaş hesaplama ve mesajla bildirim

ID : 2478
ISLEM : yaş hesaplama ve mesajla bildirim
MAKRO KODU : Dim DoğumGünü As Date Dim Yaş DoğumGünü = "01/01/1977" Yaş = FormatNumber(DateDiff("m", DoğumGünü, Now) / 12, 1) If Yaş -

yatay ve dikey saydirma

ID : 2479
ISLEM : yatay ve dikey saydirma
MAKRO KODU : Sub tabloyaaktar() Set s1 = Sheets("bilgi") Set s2 = Sheets("sonuc") s2.[c3:ag40].ClearContents For a = 2 To s1.[a65536].End(3).Row sat = Day(s1.Cells(a, "a")) + 2 sut = Day(s1.Cells(a, "b")) + 2 s2.Cells(sat, sut) = 1 + s2.Cells(sat, sut) Next End Sub

yazdıracağınız satır ve sütunları manuel olarak seçebileceğiniz kodlar

ID : 2480
ISLEM : yazdıracağınız satır ve sütunları manuel olarak seçebileceğiniz kodlar
MAKRO KODU : Sub FixArea() Dim C As Range Dim Msg$, TMP$ Msg = "Type in the range to exclude:" Set C = Application.InputBox(prompt:=Msg, Type:=8) TMP = C.NumberFormat C.NumberFormat = ";;;" ActiveSheet.Range("A1:A50").PrintPreview C.NumberFormat = TMP End Sub

yazdırılacak alanın boşluk olmadan

ID : 2481
ISLEM : yazdırılacak alanın boşluk olmadan
MAKRO KODU : Bir sutun da ki en son dolu hücreye gitmenin en basit yolu (Aralarda boşluk yok 'kabul edilerek) xlup 'Buna göre I sütununun en son dolu olan satırı Range("I65536").End(xlUp).Row 'Yazdırılacak alan ise ActiveSheet.PageSetup.PrintArea = "$A$3:$I$" & Range("I65536").End(xlUp).Row 'veya Sub yazdirmaalani() Range("A1:B16).Select ActiveSheet.PageSetup.PrintArea = Selection.Address End Sub

yazdırma alanı seçme

ID : 2482
ISLEM : yazdırma alanı seçme
MAKRO KODU : Sub yazalanı_seç() bilgi = "Yazdırmak istediğiniz hücre aralığını girin. " bilgi = bilgi + "Size uygun olanını yazmak için silin ve yazın." + Chr$(13) + Chr$(10) bilgi = bilgi + "TAMAM'a tıklayın." + Chr$(13) + Chr$(10) bilgi = bilgi + "İPTAL veya ESC basarsanız bütün tabloyu seçersiniz." + Chr$(13) + Chr$(10) düğme = "A12:K40" a$ = InputBox(bilgi, "YAZDIRMA ALANINI SEÇMEK", düğme) ActiveSheet.PageSetup.PrintArea = a$ ActiveWindow.SelectedSheets.PrintPreview Range("A13").Select End Sub

yazdırma alanı varsa bulur ve mesajla belirtir

ID : 2483
ISLEM : yazdırma alanı varsa bulur ve mesajla belirtir
MAKRO KODU : Sub Recupzone() Set zoneIMP = Range(ActiveSheet.PageSetup.PrintArea) MsgBox zoneIMP.Address() End Sub

yazdırma alanını a3:f15 yapar ve yinelenecek satırı da seçer ve yazdırır

ID : 2484
ISLEM : yazdırma alanını a3:f15 yapar ve yinelenecek satırı da seçer ve yazdırır
MAKRO KODU : Sub PrintRpt3() With Worksheets("Sayfa1").PageSetup .CenterHorizontally = True .PrintArea = "$A$3:$F$15" .PrintTitleRows = ("$A$1:$A$2") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets("Sayfa1").PrintOut End Sub

yazdırma alanını bulma

ID : 2485
ISLEM : yazdırma alanını bulma
MAKRO KODU : If ActiveSheet.PageSetup.PrintArea = "" Then MsgBox "Yazdırma alanı yok" Else MsgBox "Yazdırma Alanı: " & ActiveSheet.PageSetup.PrintArea End If

yazdırmak için süzme şart olsun

ID : 2486
ISLEM : yazdırmak için süzme şart olsun
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) If Cells(1, 1) 1 Then Cancel = True End Sub 'Bu örnek A1 hücresi 1 den farklı ise yazdırmayı iptal eder -

yazdırmak için süzme şart olsun 2

ID : 2487
ISLEM : yazdırmak için süzme şart olsun 2
MAKRO KODU : Aşğıdaki kod filter yaptığın tüm alanlara bakarak en az birinde seçim yapılmış ise sayfayı gönderir aksi halde mesaj verir.. Set s1 = ActiveSheet Secilmiş = False If s1.AutoFilterMode = True Then For i = 1 To s1.AutoFilter.Filters.Count If s1.AutoFilter.Filters.Item(i).On Then Secilmiş = True Next i If Not Secilmiş Then MsgBox "Hiç Bir Süzme İşlemi Yapılamış" Cancel = True End If End If 'Tarih alanınız 4. sutun ise ve siz burada mutlaka bir seçim olmasını istiyorsanız o zaman döngü kullanmadan şunu deneyin : s1.AutoFilter.Filters.Item(4).On Then Secilmiş = True '4 alanda seçim yapılıp yapılmadığını kontrol ediyor.

yazdırmayı engelle (üzgünüz çıktı almak yasak)

ID : 2488
ISLEM : yazdırmayı engelle (üzgünüz çıktı almak yasak)
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True MsgBox ("üzgünüz çıktı almak yasak") End Sub

yazdırmayı engelleme

ID : 2489
ISLEM : yazdırmayı engelleme
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Sheet1" Then Cancel = True End Sub

yazdir butonu sayfa yazdirilacak, önizleme yapmak istiyor musunuz

ID : 2490
ISLEM : yazdir butonu sayfa yazdirilacak, önizleme yapmak istiyor musunuz
MAKRO KODU : Private Sub yaz_Click() On Error Resume Next soru = MsgBox("Sayfa Yazdırılacak, Önizleme Yapmak İstiyor musunuz?", vbYesNo, "Önizleme") If soru = vbYes Then DataAc.Hide Sheets("Print").PrintPreview DataAc.Show Range("A1").Select Else Sheets("Print").PrintOut End If End Sub

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