Makro Kod Listesi

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

ID : 1471
ISLEM : mail gönderimi outlok ile
MAKRO KODU : Sub EmailSheet() Dim OutlookApp As Object, OutlookMsg As Object Dim FSO As Object, BodyText As Object Dim MyRange As Range, TempFile As String 'On Error Resume Next Set MyRange = ActiveSheet.UsedRange If MyRange Is Nothing Then Exit Sub Set FSO = CreateObject("Scripting.FilesystemObject") TempFile = "C:\TempHTML.htm" ActiveWorkbook.PublishObjects.Add _ (4, TempFile, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True Set OutlookApp = CreateObject("Outlook.Application") Set OutlookMsg = OutlookApp.CreateItem(0) Set BodyText = FSO.OpenTextFile(TempFile, 1) OutlookMsg.HTMLBody = BodyText.ReadAll OutlookMsg.Subject = "Merhaba !" OutlookMsg.To = "excalub@yahoo.com" 'OutlookMsg.Display OutlookMsg.Send 'Kill TempFile Set BodyText = Nothing Set OutlookMsg = Nothing Set OutlookApp = Nothing Set FSO = Nothing End Sub

ID : 1472
ISLEM : makro bitince tekrar baştan aldırma (döngü)
MAKRO KODU : for a=1 to 50 Sheets("Ana Liste").Select Rows("1:1").Select Selection.Insert Shift:=xlDown Sheets("Sayfa" & a).Select Range("C3").Select Selection.Copy next a

ID : 1473
ISLEM : makro çalıştırma 5 dakikada bir
MAKRO KODU : Sub aralıklı_calıstır() Application.OnTime Now + TimeValue("00:05:00"), "makro1" End Sub Sub makro1() msgbox("transfer başlıyor") '...sizin kodlarınız '....... call aralıklı_calıstır End sub

ID : 1474
ISLEM : makro içinde tamsayı ve tavana yuvarlama
MAKRO KODU : TavanaYuvarla için MsgBox WorksheetFunction.Ceiling(25.32, 1) Tamsayı için MsgBox Int(25.32) Aşağıdaki şekilde de kullanmanız mümkündür. ActiveCell = "=INT(10.65)" ActiveCell= "=CEILING(25.32,1)"

ID : 1475
ISLEM : makro içinde yazilan mesaj metnini değiştirmek
MAKRO KODU : Private Sub CommandButton6_Click() sor = MsgBox("SİLMEK İSTEDİĞİNİZDEN EMİNMİSİNİZ...?", vbYesNo) If sor = vbNo Then Exit Sub Application.Wait Now + TimeValue("00:00:02") / 1.5 CommandButton6.Caption = "SİL" 'sat = ListBox1.ListIndex + 2 'Range("B" & sat & ":I" & sat).Delete '[a65536].End(2).Delete Shift:=xlUp Sheets("STOKLAR").Rows(Sheets("STOKLAR").Columns(1).Find(ListBox1.Value).Row).Delete MsgBox "SEÇİLEN KAYIT SİLİNMİŞTİR" End Sub

ID : 1476
ISLEM : makro ile ayni olan hücreleri silme.
MAKRO KODU : aşağıdaki makro sadece hücredeki değerleri siler. Sub Makro1() x = WorksheetFunction.CountA(Range("A1:A65000")) For a = 1 To x b = Cells(a, 1).Value For c = a + 1 To x d = Cells(c, 1).Value If b = d Then Cells(c, 1).ClearContents End If Next c Next a End Sub

ID : 1477
ISLEM : makro ile belirli bir hücreye sayfa sayisi yazdirma
MAKRO KODU : Aşağıdaki kodu deneyin. Yazdırılacak sayfa sayısını verir. Sub sayfasay() Application.ScreenUpdating = False ActiveWindow.View = 2 say = ActiveSheet.HPageBreaks.Count + 1 ActiveWindow.View = 1 MsgBox say End Sub

ID : 1478
ISLEM : makro ile birleştir formülünü oluşturma
MAKRO KODU : Çalışma sayfasının kod bölümüne girilecek kodlar: Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 And Target.Row = 1 Then X = [A1] & [A2] & [A3] & [A4] & [A5] [A1] = X End If End Sub

ID : 1479
ISLEM : makro ile dosya açma problemi
MAKRO KODU : Workbooks.Open Filename:=activeworkbook.path & "\satis.xls"

ID : 1480
ISLEM : makro ile form import etmek
MAKRO KODU : Makro ile Import için; Sub import_form() Application.VBE.ActiveVBProject.VBComponents.Import ("C:\Documents and Settings\bulent\Desktop\UserForm1.frm") End Sub 'C:\Documents and Settings\bulent\Desktop\UserForm1.frm - dosya yolunu kendinize uyarlayın

ID : 1481
ISLEM : makro ile geri al (undo)
MAKRO KODU : Application:Undo

ID : 1482
ISLEM : makro ile gizlediğimiz sheet i açmak için yazacağimiz makraya şifre sormasini sağlaya bilirmiyiz
MAKRO KODU : VBA da thisworkbook kısmına Kod: Private Sub Workbook_SheetActivate(ByVal Sh As Object) If LCase(Sh.Name) = "sheet1" Or LCase(Sh.Name) = "sheet2" Then If InputBox("şifreyi girin") <> "sifre" Then Sh.Visible = False End If End Sub

ID : 1483
ISLEM : makro ile hücre birleştirme
MAKRO KODU : Range("A1:D1").Merge

ID : 1484
ISLEM : makro ile kopyalama ve yapiştirma
MAKRO KODU : Private Sub Worksheet_Activate() Set Sh1 = Sheets("Sevk") Set Sh2 = Sheets("Anasayfa") If Sh2.Range("E8").FormulaR1C1 <> "" Then Sh1.[C3] = Sh2.[Z2] 'Kurum Adı' Sh1.[D11] = Sh2.[Z3] 'Kurum Amiri' Sh1.[D12] = Sh2.[Z4] 'Kurum Amirinin Unvanı' Sh1.[C5] = Sh2.[Z5] 'Memurun Adı Soyadı' Sh1.[C7] = Sh2.[Z6] 'Memurun Unvanı' Sh1.[E5] = Sh2.[Z7] 'Hastanın Adı Soyadı' Sh1.[C15] = Sh2.[Z8] 'Sağlık Kurumu' Sh1.[F11] = Sh2.[Z9] 'Tarih' Sh1.[C9] = Sh2.[Z10] 'Adres' Sh1.[F3] = Sh2.[Z11] 'T.C. Kimlik No' Sh1.[E7] = Sh2.[Z12] 'Sicil No' Sh1.[F7] = Sh2.[Z13] 'Derece/Kadro' Sh1.[F13] = Sh2.[Z14] 'Sayı' End If Set Sh1 = Nothing Set Sh2 = Nothing End Sub

ID : 1485
ISLEM : makro ile sayfa silmek
MAKRO KODU : Sub Sayfa_Sil() Dim sil As String Application.DisplayAlerts = False sil = ActiveSheet.Name Sheets.Add Sheets(sil).Select ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True End Sub

ID : 1486
ISLEM : makro ile tarih çıkarma cevap gün olarak
MAKRO KODU : Sub DatumVBA() MsgBox CLng(CDate("29.11.2005")) - CLng(CDate("05.04.1978")) End Sub

ID : 1487
ISLEM : makro istediğim tarihten sonra açılmasın
MAKRO KODU : kodların başına If Date>=Cdate("23.02.2006") then Exit sub 'satırını ilave ediniz

ID : 1488
ISLEM : makro kodlarında hata mesajı verdirme
MAKRO KODU : Sub ErrHand() On Error GoTo ErrorHandler n = 10 Selection.SpecialCells(xlConstants).Select x = Selection.Areas MsgBox (x) Exit Sub ErrorHandler: Select Case Err.Number Case 104 MsgBox ("104") Exit Sub Case Else MsgBox "Runtime Error: " & Err.Number & vbNewLine & Err.Description Stop Resume End Select End Sub

ID : 1489
ISLEM : makroda bir veya birden çok değer döndürmek
MAKRO KODU : bu dosyanın amacı sadece filtre yönetimini genelleştirmek olduğu için başka bir şeye ihtiyaç duymadım. yani marifet formda değil kodlarda. Anlaşılan hala anlatım zorluğu çekiyorum. bu modul tek kriterli olan tüm filtreler için kullanılabilir. kodlar aynen şöyle visual basic kodu: -------------------------------------------------------------------------------- Global adres As String 'excel.web.tr'den 'Bu Makro genel filtre amaçlıdır. '****************************************************** ' AÇIKLAMA '****************************************************** // Örnekler 'KaynakSayfa : Filrelemenin yapılacağı sayfa // "stok" 'FiltreBaşlığı : Filtrelenmek istenen tablonun başlığı // "A1:C1" 'FiltreAlanı : Filtrenin uygulanacağı alan // 3 "yani c1 hücresi" 'Ölçüt : Büyüklük,küçüklük...(>,<,=,<>..) // "=" 'Kriter : Filtrelenen değer // Combobox1.text 'AdresAlanı : Filtre sonucu alınmak istenen verilerin alanı // "A1:B1" 'HedefSayfa : Filtrelenen verilerin kopyalanacağı sayfa // "stok" 'HedefAlan : Filtrelenen verilerin kopyalanacağı alan // "H1:I1" 'NOT:Hata denetim işlemleri henüz yapılmadı Sub AdresAl(KaynakSayfa, FiltreBaşlığı, Ölçüt, Kriter, AdresAlanı, HedefSayfa, HedefAlan As String, FiltreAlanı As Integer) Application.ScreenUpdating = False Sheets(HedefSayfa).Select Range(Range(HedefAlan), Range(HedefAlan).End(xlDown)).Clear Sheets(KaynakSayfa).Select Range(FiltreBaşlığı).AutoFilter Range(FiltreBaşlığı).AutoFilter Field:=FiltreAlanı, Criteria1:=Ölçüt & Kriter, Operator:=xlAnd Range(Range(AdresAlanı), Range(AdresAlanı).End(xlDown)).Copy Sheets(HedefSayfa).Select Range(HedefAlan).Select ActiveSheet.Paste Sheets(KaynakSayfa).AutoFilterMode = False Application.CutCopyMode = False adres = HedefSayfa & "!" & Range(Range(HedefAlan), Range(HedefAlan).End(xlDown)).Address End Sub -------------------------------------------------------------------------------- kullanmak için örnek kodlar: visual basic kodu: -------------------------------------------------------------------------------- Private Sub ComboBox1_Change() Call AdresAl("stok", "A1:C1", "=", ComboBox1.Text, "A1:B1", "stok", "H1:I1", 3) ListBox1.RowSource = adres End Sub -------------------------------------------------------------------------------- visual basic kodu: -------------------------------------------------------------------------------- Private Sub ComboBox2_Change() Call AdresAl("firma", "A1:C1", "=", ComboBox2.Text, "A1:B1", "firma", "H1:I1", 3) ListBox2.RowSource = adres End Sub

ID : 1490
ISLEM : makroda bul ve kopyala yapiştir
MAKRO KODU : aşağıdaki örnek işinizi görür sanırım; Makroyu çalıştırdığın sayfada işlem yapar. Kod: 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 : 1491
ISLEM : makroda hesaplanıyor mesajı
MAKRO KODU : Private Sub Tamam_Click() Application.StatusBar = "Hesaplama Yapılıyor" Tamam.Enabled = False 'Hesaplama ile ilgili kodlar '.......... '.......... 'Hesaplama ile ilgili kodlar Application.StatusBar = "Hesaplama Tamamlandı" Tamam.Enabled = True End Sub

ID : 1492
ISLEM : makro'da kenarlik ?
MAKRO KODU : Sub TestRng() Dim rng As Range Set rng = Range("A2:b4") 'Excel macro test code 'Note iRow = Start Row of Range and iRow2= Ending Row of Range 'Set rng = oXLApp.Range(Cells(iRow, 1), oXLApp.Cells(iRow2,1).End(xlToRight)) grid rng End Sub Sub grid(rng) rng.Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End Sub

ID : 1493
ISLEM : makrolar kutusu ve makrolar görünsün
MAKRO KODU : Aşağıdaki kodlarla makrolar kutusunun görünmemesini sağladım. Fakat şimdi tekrar eski konumuna dönsün istiyorum. Bu kodları henüz bitirmediğim bir çalışma dosyamda denedim.Daha sonra iptal etmek için araç çubukları üzerinde sağ tıklayıp modülden auto_open ve auto_close makrolarından bu kodları sildim ama yinede araç çubuklarında makrolar görünmüyor. Yardımcı olursanız sevinirim. Teşekkürler. Kod: Sub auto_open() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = False Application.OnKey "%{F11}", "mesaj" End Sub Sub auto_close() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = True Application.OnKey "%{F11}" End Sub Sub mesaj() MsgBox "Makrolar gizli!!" End Sub '************** Başka bir dosyada sizin yukarıdaki auto_close prosedurunu yerleştirip, çalıştırın. Veya aşağıdakini deneyin; Kod: Sub Panzehir() Application.CommandBars("Worksheet Menu Bar").Reset Application.OnKey "%{F11}" End Sub Eğer kodları yerleştirmek için VBE kısmına ulaşamıyorsanız, aşağıdaki dosyayı indirip, açın. Bu arada ufak bir hatırlatma; İngilizce Office yüklü bir bilgisayarda kodlarınız hata verecektir çünkü, menülere "etiket - başlık" ile referans vermişiniz. Bunun yerine menünün ID özelliğini kullanırsanız İngilizce-Türkçe-... bütün versiyonlarda kodlar çalışır. Ayrıca, menülerini özelleştiren birisinin bilgisayarında menü çubuğunda 6ncı menü "Tools-Araçlar" menüsü olmayabilir ve bu nedenle de yine hata verebilir. Bu yüzden menülere her zaman ID'leri ile referans vermekte fayda vardır. Aşağıdaki resimde görüldüğü gibi, "Makro" veya "Makrolar" menüsü/dialog kutusu veya kod sayfası yani VBE (Visual Basic Editor)'ün kendisi Excel'in çeşitli yerlerinden aktive edilebilir. Örneğin, sayfa sekmesi üzerinde farenin sağ tuşuna basarak, Excel'in menü çubuğundaki Excel ikonunun üzerinde farenin sağ tuşuna basarak, normal yollarlla menülerden, Visual Basic araç çubuğundan, .... Bu durumda benim önerim aşağıdaki gibidir; Kod: Sub Auto_Open() Application.CommandBars.FindControl(ID:=30017).Enabled = False Application.CommandBars.FindControl(ID:=186).Enabled = False Application.CommandBars.FindControl(ID:=1561).Enabled = False Application.CommandBars("Ply").FindControl(ID:=1561).Enabled = False Application.CommandBars("Document").FindControl(ID:=1561).Enabled = False Application.CommandBars("Visual Basic").Enabled = False Application.CommandBars("Control ToolBox").Enabled = False Application.OnKey "%{F11}", "Mesaj" Application.OnKey "%{F8}", "Mesaj" End Sub ' Sub Auto_Close() Application.CommandBars.FindControl(ID:=30017).Enabled = True Application.CommandBars.FindControl(ID:=186).Enabled = True Application.CommandBars.FindControl(ID:=1561).Enabled = True Application.CommandBars("Ply").FindControl(ID:=1561).Enabled = True Application.CommandBars("Document").FindControl(ID:=1561).Enabled = True Application.CommandBars("Visual Basic").Enabled = True Application.CommandBars("Control ToolBox").Enabled = True Application.OnKey "%{F11}" Application.OnKey "%{F8}" End Sub ' Sub Mesaj() MsgBox "Makrolar gizli!!" End Sub Dip Not: Eğer amaç kullanıcıdan makroları gizlemekse; makroların olduğu modulün en üstüne aşağıdaki satırı yerleştirdiğinizde, kullanıcı bahsettiğiniz menüler aktifken bile sözkonusu moduldeki makrolar listelenmez. Çünkü o modül tıpkı sayfa veya UserForm modulleri gibi "Private-Özel" bir modül olacaktır.

ID : 1494
ISLEM : makroları otomatik açılması, çalışması, kapanması
MAKRO KODU : Dim RunWhen As Double Const RunWhat = "Info" Sub Auto_Open() StartTimer End Sub Sub StartTimer() RunWhen = Now + TimeSerial(0, 0, 5) Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=True End Sub Sub Info() ' Aşağıdaki satırda yer alan MsgBox fonksiyonu yerine, ' çalıştırılmasını istediğiniz başka bir makronun adını yazarak ' o makronun çalıştırılmasını sağlayabilirsiniz. MsgBox "Dikkat, sayfayi güncelleyin !" StartTimer End Sub Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=False End Sub Sub Auto_Close() StopTimer End Sub

ID : 1495
ISLEM : makroların istenilen sayfada çalışması
MAKRO KODU : Sub Auto_Open() If ActiveSheet.Name = "Sayfa1" Then Range("B3") = "Evren1" 'Buraya Call::::::. makro ismi de yazılabilir End If End Sub Sub z() If ActiveSheet.Name = "Sayfa1" Then Range("B4") = "Evren2" 'Buraya Call::::::. makro ismi de yazılabilir End If End Sub

ID : 1496
ISLEM : makrolarınız gizli olsun diyorsanız
MAKRO KODU : Sub auto_open() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = False Application.OnKey "%{F11}", "mesaj" End Sub Sub auto_close() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = True Application.OnKey "%{F11}" End Sub Sub mesaj() MsgBox "Makrolar gizli!!" End Sub

ID : 1497
ISLEM : makrolariniz gizli olsun diyorsaniz
MAKRO KODU : kodları kopyala alt+F11-insert-module 'den sonra yapıştırarak kullanabilirsiniz...Kolay gelsin Kod: Sub auto_open() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = False Application.OnKey "%{F11}", "mesaj" End Sub Sub auto_close() Application.CommandBars("Worksheet Menu Bar").Controls(6).Controls("Makro").Enabled = True Application.OnKey "%{F11}" End Sub Sub mesaj() MsgBox "Makrolar gizli!!" End Sub

ID : 1498
ISLEM : makronun çalişmasi a1 hücresine 1000 yazip aşağidaki kodu çaliştirin
MAKRO KODU : A1 hücresine 1000 yazıp aşağıdaki kodu çalıştırın. Kod: Sub sıfır() Do Until [a1] = 0 [a1] = [a1] - 1 Loop End Sub

ID : 1499
ISLEM : makronun otomatik olarak acilmasi ve calismasi
MAKRO KODU : Aşağıdakileri sözkonusu dosyada yeni bir module yapıştırdıktan sonra kaydedin ve kapatın. Daha sonra dosyayı tekrar açın. Kod: Dim RunWhen As Double Const RunWhat = "Info" ' Sub Auto_Open() StartTimer End Sub ' Sub StartTimer() RunWhen = Now + TimeSerial(0, 0, 5) Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=True End Sub ' Sub Info() ' Aşağıdaki satırda yer alan MsgBox fonksiyonu yerine, ' çalıştırılmasını istediğiniz başka bir makronun adını yazarak ' o makronun çalıştırılmasını sağlayabilirsiniz. MsgBox "Dikkat, sayfayi güncelleyin !" StartTimer End Sub ' Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=False End Sub ' Sub Auto_Close() StopTimer End Sub

ID : 1500
ISLEM : makronun sadece bulunulan dosyada çalışması
MAKRO KODU : ‘Yaptırdığınız işlemlerin başına Thisworkbook ekleyerek yapabilirsiniz. ThisWorkbook.Sheets(1)....