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


dolu kayıt sayısı

ID : 691
ISLEM : dolu kayıt sayısı
MAKRO KODU : Sub DoluKayitSayisi() Sayi = WorksheetFunction.CountA(Range("A1:A9000")) 'Eğer mesajla almak isterseniz şu koduda ekleyin MsgBox Sayi End Sub

dolu olanları diğer sayfaya aktarır

ID : 692
ISLEM : dolu olanları diğer sayfaya aktarır
MAKRO KODU : Private Sub CommandButton1_Click() Dim MyRng As Range Dim NoA1 As Long Set sh1 = Sheets("Sayfa1") Set sh2 = Sheets("Sayfa2") NoA1 = sh1.Cells(65536, 1).End(xlUp).Row For Each MyRng In sh1.Range("A1:A" & NoA1) NoA2 = sh2.Cells(65536, 1).End(xlUp).Row + 1 If MyRng "m.cinsi" And MyRng "" Then sh2.Range("A" & NoA2) = MyRng sh2.Range("B" & NoA2) = MyRng.Offset(0, 1) sh2.Range("C" & NoA2) = MyRng.Offset(0, 2) sh2.Range("D" & NoA2) = MyRng.Offset(0, 3) End If Next End Sub -

dolu olanları seçmek (satır değişken sütun sabit)

ID : 693
ISLEM : dolu olanları seçmek (satır değişken sütun sabit)
MAKRO KODU : activesheet.usedrange.select veya, C2 den başlayarak C sütunundaki son dolu hücreye kadar seçim: range("c2:c" & cells(65536, 3).end(xlup).row).select başka bir yazım şekli de; range("c2:c" & range("c65536").end(xlup).row).select

dolu satır ve sütunu kesiştirerek seçme (mükemmel)

ID : 694
ISLEM : dolu satır ve sütunu kesiştirerek seçme (mükemmel)
MAKRO KODU : Sub SelAllData() Application.ScreenUpdating = False Dim myLastRow As Long Dim myLastColumn As Long Range("A1").Select On Error Resume Next myLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row myLastColumn = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column myLastCell = Cells(myLastRow, myLastColumn).Address myRange = "a1:" & myLastCell Application.ScreenUpdating = True Range(myRange).Select End Sub

dolu textbox sayısını mesajla bildir

ID : 695
ISLEM : dolu textbox sayısını mesajla bildir
MAKRO KODU : Private Sub CommandButton1_Click() Dim say Dim ekle On Error Resume Next For say = 1 To UserForm1.Controls.Count If Mid(Controls(say).Name, 1, 7) = "TextBox" Then GoTo ileri Else GoTo gec End If ileri: If Controls(say).Text "" Then ekle = ekle + 1 End If gec: Next say MsgBox ekle End Sub -

dolu, yazılı alanların seçilmesi ve enson dolu hücrenin bulunması

ID : 696
ISLEM : dolu, yazılı alanların seçilmesi ve enson dolu hücrenin bulunması
MAKRO KODU : Function LastCell(ws As Worksheet) As Range Dim LastRow&, LastCol% On Error Resume Next With ws LastRow& = .Cells.Find(What:="*", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row LastCol% = .Cells.Find(What:="*", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns).Column End With Set LastCell = ws.Cells(LastRow&, LastCol%) End Function Sub RealLastCell() RLC = LastCell(ActiveSheet).Address(False, False) MsgBox ("The ""real"" last cell is..." & vbCrLf & vbLf & RLC) End Sub Sub Used_Range() ActiveSheet.UsedRange.Select End Sub

dosya açık mı değil mi bakar değilse açar

ID : 697
ISLEM : dosya açık mı değil mi bakar değilse açar
MAKRO KODU : Function WorkbookOpen(WorkBookName As String) As Boolean WorkbookOpen = False On Error GoTo WorkBookNotOpen If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function End If WorkBookNotOpen: End Function Sub AA() If Not WorkbookOpen("C.xls") Then Workbooks.Open "C.xls" End If End Sub

dosya açıldığında tanımlama bilgisi

ID : 698
ISLEM : dosya açıldığında tanımlama bilgisi
MAKRO KODU : Sub auto_open() Sheets("GİRİŞ").Select Range("a1").Select MsgBox "GİRİŞ Sayfasındaki gerekli bilgileri doldurun " End Sub 'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox("Programlayan : Mahmut BAYRAM" & vbNewLine & vbNewLine & _ "Sonuçları kontrol etmeyi unutmayın!" & vbNewLine & vbNewLine & _ "sayfaları kopyalayabilirsiniz. ", vbInformation, "UYARI") End Sub

dosya açıldığında tanimlama bilgisi

ID : 699
ISLEM : dosya açıldığında tanimlama bilgisi
MAKRO KODU : Sub auto_open() Sheets("GİRİŞ").Select Range("a1").Select MsgBox "GİRİŞ Sayfasındaki gerekli bilgileri doldurun " End Sub 'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox("Programlayan : pir." & vbNewLine & vbNewLine & _ "Sonuçları kontrol etmeyi unutmayın!" & vbNewLine & vbNewLine & _ "sayfaları kopyalayabilirsiniz. ", vbInformation, "UYARI") End Sub

dosya açıp içerisine veri girme

ID : 700
ISLEM : dosya açıp içerisine veri girme
MAKRO KODU : Sub DateiAuswahl() Dim WB As Workbook Dim TB As Worksheet Dim i% Dim dName Dim dFilter$ dFilter = "Excel-Dateien(*.xls), *.xls" ChDrive "c" ChDir "c:\" dName = Application.GetOpenFilename(dFilter) If dName = False Then Exit Sub Set WB = Workbooks.Open(dName) Set TB = WB.Worksheets(1) For i = 1 To 20 TB.Cells(i, 5) = "Spalte E - Zeile " & i Next i End Sub

dosya adı, yolu ve çalışma sayfası adını fornsiyonlarla yazdır

ID : 701
ISLEM : dosya adı, yolu ve çalışma sayfası adını fornsiyonlarla yazdır
MAKRO KODU : UYARI: Aşağıdaki işlevlerin sonuç verebilmesi için çalışma kitabının kaydedilmiş olması gerekmektedir. Çalışma kitabının tam yolunu, adını ve çalışma sayfası adını birlikte yazdırmak için; =HÜCRE("DosyaAdı") Çalışma kitabının yolunu yazdırmak için; =SOLDAN(HÜCRE("DosyaAdı");BUL("[";HÜCRE("DosyaAdı");1)-1) Çalışma kitabı adını dosya uzantısı ile birlikte yazdırmak için; =PARÇAAL(HÜCRE("DosyaAdı");MBUL("[";HÜCRE("DosyaAdı");1)+1;MBUL("]";HÜCRE("DosyaAdı");1)-MBUL("[";HÜCRE("DosyaAdı"))-1) Çalışma kitabı adını dosya uzantısı olmaksızın yazdırmak için; =PARÇAAL(HÜCRE("DosyaAdı");MBUL("[";HÜCRE("DosyaAdı");1)+1;MBUL("]";HÜCRE("DosyaAdı");1)-MBUL("[";HÜCRE("DosyaAdı"))-5) Çalışma sayfası adını yazdırmak için; =SAĞDAN(HÜCRE("DosyaAdı");UZUNLUK(HÜCRE("DosyaAdı"))-MBUL("]";HÜCRE("DosyaAdı");1))

dosya al

ID : 702
ISLEM : dosya al
MAKRO KODU : Tek başına bir işe yaramayan bir kod. Adı geçen dosya ismi hafızada tutuluyor ve işlemler bu dosya üzerinden yapılıyor. Örnekler ikinci bölümde 'verilecektir. Sub Dosya_Al() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.GetFile("D:\ExcelÖrnekleri\Soru.xls") MsgBox f End Sub 'Bu kodda ise dosya değil,sadece ismi alınıyor. Sub Dosya_İsmi_Al() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") f = ds.GetFileName("D:\ExcelÖrnekleri\Soru.xls") 'Sadece Dosya ismi alındığı için SET tabiri kullanılmaz MsgBox f End Sub

dosya arama

ID : 703
ISLEM : dosya arama
MAKRO KODU : Sub ProcessBooks() Dim wkbk As Workbook Dim i As Long With Application.FileSearch .NewSearch .LookIn = "C:\My Documents" .SearchSubFolders = False .FileName = "*.xls" .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then

dosya arama (var mı, yok mu)

ID : 704
ISLEM : dosya arama (var mı, yok mu)
MAKRO KODU : Sub dosya_ara() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.FileExists("C:\testfile.txt") If a = True Then MsgBox "Bu isimde bir dosya var" Else MsgBox "Bu isimde bir dosya yok" End If End Sub

dosya arama 2

ID : 705
ISLEM : dosya arama 2
MAKRO KODU : Diskteki istediğiniz dosyaları (alt klasörler dahil) nasıl bulacağınız ve bir comboda nasıl listeleyeceğiniz yazıyor. 'Bir forma btnara ismli bir düğme ve comsonuc isimli bir combobox yerleştirmeniz yeterli. Private Sub btnara_Click() comsonuc.Clear comsonuc.Refresh Dim arama As Object Dim aradosya As Object Set arama = CreateObject("FileSearch.Search") Call arama.SearchFiles("d:\", "*.mp3", True) Call arama.SearchFiles("C:\", "*.xls", True) DoEvents If arama.Files.Count > 0 Then For Each aradosya In arama.Files comsonuc.AddItem aradosya.FileName Set aradosya = Nothing Next End If Set arama = Nothing comsonuc.text="ARAMA BİTTİ" End Sub

dosya arayıp bulsun varsa onaylasın

ID : 706
ISLEM : dosya arayıp bulsun varsa onaylasın
MAKRO KODU : Sub Existe() If Dir$("c:\ajeter\test.xls") = "" Then MsgBox " Pas trouvé ce fichier :O(" Else MsgBox " OK ! Trouvé :O)" End If End Sub

dosya cd rom ismin kontrol ediyor tutmuyorsa kapatıyor

ID : 707
ISLEM : dosya cd rom ismin kontrol ediyor tutmuyorsa kapatıyor
MAKRO KODU : Sub auto_open() Dim fso, drv, cdr Set fso = CreateObject("Scripting.FileSystemObject") For Each drv In fso.Drives If drv.driveType = 4 Then Set cdr = drv Next If cdr.volumename "CD nin adı" Then MsgBox "Lütfen program cd sini takmadan programı çalıştırmayınız" ThisWorkbook.Close False End If End Sub -

dosya dizinde mi bakar, varsa açar yoksa mesaj verir

ID : 708
ISLEM : dosya dizinde mi bakar, varsa açar yoksa mesaj verir
MAKRO KODU : Function FileExists(FullFileName As String) As Boolean FileExists = Len(Dir(FullFileName)) > 0 End Function Sub ss() If Not FileExists("C:\f.xls") Then MsgBox "Aradığınız dosya belirtilen dizinde yok" Else Workbooks.Open "C:\f.xls" End If End Sub

dosya düzen çubuğuna menü ekleme silme

ID : 709
ISLEM : dosya düzen çubuğuna menü ekleme silme
MAKRO KODU : Modüle Option Explicit Sub CreateMenu() ' creates a new menu. ' can also be used to create commandbarbuttons ' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl RemoveMenu ' delete the menu if it already exists ' create a new menu on an existing commandbar (the next 6 lines) Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With cbMenu .Caption = "&My menu" .Tag = "MyTag" .BeginGroup = False End With ' or add to an existing menu (use the next line instead of the previous 6 lines) 'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Tools-menu If cbMenu Is Nothing Then Exit Sub ' didn't find the menu... ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Menu Item1" .OnAction = ThisWorkbook.Name & "!Macroname" End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Menu Item2" .OnAction = ThisWorkbook.Name & "!Macroname" End With ' add a submenu Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu .Caption = "&Submenu1" .Tag = "SubMenu1" .BeginGroup = True End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Submenu Item1" .OnAction = ThisWorkbook.Name & "!Macroname" .Style = msoButtonIconAndCaption .FaceId = 71 .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Submenu Item2" .OnAction = ThisWorkbook.Name & "!Macroname" .Style = msoButtonIconAndCaption .FaceId = 72 .Enabled = False ' or True End With ' add a submenu to the submenu Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu .Caption = "&Submenu2" .Tag = "SubMenu2" .BeginGroup = True End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Submenu Item1" .OnAction = ThisWorkbook.Name & "!Macroname" .Style = msoButtonIconAndCaption .FaceId = 71 .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Submenu Item2" .OnAction = ThisWorkbook.Name & "!Macroname" .Style = msoButtonIconAndCaption .FaceId = 72 .Enabled = False ' or True End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = "&Remove this menu" .OnAction = ThisWorkbook.Name & "!RemoveMenu" .Style = msoButtonIconAndCaption .FaceId = 463 .BeginGroup = True End With Set cbSubMenu = Nothing Set cbMenu = Nothing End Sub Sub RemoveMenu() ' may be automatically executed from an Auto_Close macro or a Workbook_BeforeClose eventmacro DeleteCustomCommandBarControl "MyTag" ' deletes the new menu End Sub Private Sub DeleteCustomCommandBarControl(CustomControlTag As String) ' deletes ALL occurences of commandbar controls with a tag = CustomControlTag 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 ShowHideMenu(MenuVisible As Boolean) ' may be automatically executed from an Workbook_Activate macro or a Workbook_Deactivate eventmacro ChangeControlVisibility "MyTag", MenuVisible ' toggles menu visibility End Sub Private Sub ChangeControlVisibility(CustomControlTag As String, MenuVisible As Boolean) ' toggles menu visibility On Error Resume Next Application.CommandBars.FindControl(, , CustomControlTag, False).Visible = MenuVisible On Error GoTo 0 End Sub Sub Macroname() ' used by the menuitems created by the CreateMenu macro MsgBox "This could be your macro running!", vbInformation, ThisWorkbook.Name End Sub 'Thisworkbook a Private Sub Workbook_Activate() ShowHideMenu True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) RemoveMenu End Sub Private Sub Workbook_Deactivate() ShowHideMenu False End Sub Private Sub Workbook_Open() CreateMenu End Sub

dosya düzen menülerinin iptali ve yeni menü

ID : 710
ISLEM : dosya düzen menülerinin iptali ve yeni menü
MAKRO KODU : Sub MenuErstellen() Dim MB As CommandBar Dim Ctrl1 As CommandBarControl Dim Ctrl2 As CommandBarControl Dim Ctrl1a As CommandBarControl Dim Ctrl1b As CommandBarControl Set MB = CommandBars.Add(Name:="Neues Menü", MenuBar:=True) Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup) Ctrl1.Caption = "Untermenü1" Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup) Ctrl2.Caption = "Untermenü2" Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1a.Caption = "Daten" Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1b.Caption = "Übertragen" CommandBars("Neues Menü").Visible = True End Sub

dosya düzen menüsüne menü ekleme

ID : 711
ISLEM : dosya düzen menüsüne menü ekleme
MAKRO KODU : Private Sub Workbook_Activate() MenuBars(xlWorksheet).Menus.Add "&Test Menü" Set ml = MenuBars(xlWorksheet).Menus("Test Menü") With ml .MenuItems.Add Caption:="&Daten erfassen", _ OnAction:="DatenSpeichern" .MenuItems.AddMenu Caption:="&Auswertungen" With .MenuItems("Auswertungen") .MenuItems.Add Caption:="&Auswertung1", _ OnAction:="" .MenuItems.Add Caption:="A&uswertung2", _ OnAction:="" End With End With End Sub Private Sub Workbook_Deactivate() MenuBars(xlWorksheet).Reset End Sub Private Sub Workbook_Open() MenuBars(xlWorksheet).Menus.Add "&Test Menü" Set ml = MenuBars(xlWorksheet).Menus("Test Menü") With ml .MenuItems.Add Caption:="&Daten erfassen", _ OnAction:="DatenSpeichern" .MenuItems.AddMenu Caption:="&Auswertungen" With .MenuItems("Auswertungen") .MenuItems.Add Caption:="&Auswertung1", _ OnAction:="" .MenuItems.Add Caption:="A&uswertung2", _ OnAction:="" End With End With End Sub

dosya düzen menüsünü gizleme ve gösterme

ID : 712
ISLEM : dosya düzen menüsünü gizleme ve gösterme
MAKRO KODU : Sub Menueleiste_ausblenden() Application.CommandBars("Worksheet Menu Bar").Enabled = False End Sub Sub Menueleiste_einblenden() Application.CommandBars("Worksheet Menu Bar").Enabled = True End Sub

dosya düzen menüsünü silme

ID : 713
ISLEM : dosya düzen menüsünü silme
MAKRO KODU : Sub supBA() For Each LaBarMenu In ActiveMenuBar.Menus LaBarMenu.Delete Next MsgBox "Barre de menus supprimée !" ActiveMenuBar.Reset MsgBox "Barre de menus rétablie !" End Sub Sub ac() Application.CommandBars(1).Enabled = True End Sub

dosya isimleri

ID : 714
ISLEM : dosya isimleri
MAKRO KODU : Sub Dosya_İsimleri() Dim ds, dc, f, s Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.GetFolder("C:\SXS") Set dc = f.Files For Each dosya In dc s = s & vbCrLf & dosya.Name Next MsgBox s End Sub

dosya isimlerin excele atamak

ID : 715
ISLEM : dosya isimlerin excele atamak
MAKRO KODU : Sub Dosyalar() Dim Klasor As String Dim Dosya As String Dim i As Integer Klasor = "C:\osman" Dosya = Dir(Klasor & Application.PathSeparator & "*.*", vbDirectory) Do While Dosya "" Cells(i + 1, 1) = Dosya i = i + 1 Dosya = Dir Loop End Sub -

dosya kaç kere açılmış

ID : 716
ISLEM : dosya kaç kere açılmış
MAKRO KODU : ThisWorkbook'a Private Sub Workbook_Open() Worksheets("Sayfa1").Range("A1").Value = Worksheets("Sayfa1").Range("A1").Value + 1 MsgBox "Bu dosya " & Worksheets("Sayfa1").Range("A1").Value & " kez açıldı" & vbCrLf & "En son açan : " & Worksheets("Sayfa1").Range("B1") Worksheets("Sayfa1").Range("B1") = Application.UserName ThisWorkbook.Save End Sub

dosya klasör ekle

ID : 717
ISLEM : dosya klasör ekle
MAKRO KODU : Sub Auto_Open() 'belirtilen dizinde "pir" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir("C:\pir") = "" Then MkDir "C:\pir" Sheets("Sheet1").Select End Sub Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = "C:\pir.xls" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close End Sub

dosya klasör ekle

ID : 718
ISLEM : dosya klasör ekle
MAKRO KODU : Sub Auto_Open() 'belirtilen dizinde "mahmut" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir("C:\mahmut") = "" Then MkDir "C:\pir" Sheets("Sheet1").Select End Sub Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = "C:\mahmut.xls" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close End Sub

dosya listeleme

ID : 719
ISLEM : dosya listeleme
MAKRO KODU : Sub dosya_listeleme() Dim datename As String, i As Integer datename = Dir$("C:\Documents and Settings\pir\Belgelerim\*.xls") Do While datename "" ActiveCell.Offset(i, 0) = datename i = i + 1 datename = Dir$() Loop End Sub -

dosya menüsü hariç diğer araç çubuklarının gizlenmesi

ID : 720
ISLEM : dosya menüsü hariç diğer araç çubuklarının gizlenmesi
MAKRO KODU : Sub Verstecken() For Each tb in Toolbars tb.Visible = False Next tb End Sub

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