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


kitabınızın kapanması bir hücrenin değerine bağlı ise

ID : 1321
ISLEM : kitabınızın kapanması bir hücrenin değerine bağlı ise
MAKRO KODU : This workbook kısmına; Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Worksheets("Sayfa1").Range("A1").Value -

kitabi kapat kitabi kaydet

ID : 1322
ISLEM : kitabi kapat kitabi kaydet
MAKRO KODU : Çalışma Kitabını Kapat Sub kayıt() ActiveWorkbook.Close End Sub Çalışma Kitabını Kaydet Sub kayıt() ActiveWorkbook.Save End Sub

kitabi kaydet pencereyi kapat a1'i seç

ID : 1323
ISLEM : kitabi kaydet pencereyi kapat a1'i seç
MAKRO KODU : KİTABI KAYDET PENCEREYİ KAPAT A1'İ SEÇ Private Sub CommandButton6_Click() ActiveWorkbook.Save ActiveWindow.Close Range("A1").Select End Sub

kitabi otomatik kaydetme

ID : 1324
ISLEM : kitabi otomatik kaydetme
MAKRO KODU : ÇALIŞMA KİTABINI KAPATTIĞINIZDA KİTABI OTOMATİK KAYIT YAPAR VEYA YAPMAZ Sub Auto_close() Workbooks("Kitap1.xls").Close True 'False kaydetmeden kitabı kapar End Sub

kitap açılırken bu gün tarihli yedek alır

ID : 1325
ISLEM : kitap açılırken bu gün tarihli yedek alır
MAKRO KODU : Private Sub Workbook_Open() Dim StDatei As String Dim StPhad As String StDatei = ThisWorkbook.Name ' Dateiname StPhad = ThisWorkbook.Path ' Phad Dim Fso As Object Set Fso = CreateObject("Scripting.FileSystemObject") If Fso.FileExists(StPhad & "\" & Format(Now, "DD-MM-YY") & "_" & Format(Now, "hh-mm") & "_" & StDatei) Then Kill StPhad & "\" & Format(Now, "DD-MM-YY") & "_" & Format(Now, "hh-mm") & "_" & StDatei End If ActiveWorkbook.SaveCopyAs FileName:=StPhad & "\" & Format(Now, "DD-MM-YY") & "_" & Format(Now, "hh-mm") & "_" & StDatei End Sub

kitap açma (1 den fazla dosya)

ID : 1326
ISLEM : kitap açma (1 den fazla dosya)
MAKRO KODU : Sub OpenMultipleFiles() Dim fn As Variant, f As Integer fn = Application.GetOpenFilename("Excel-files,*.xls", _ 1, "Select One Or More Files To Open", , True) If TypeName(fn) = "Boolean" Then Exit Sub For f = 1 To UBound(fn) Debug.Print "Selected file #" & f & ": " & fn(f) Workbooks.Open fn(f) MsgBox ActiveWorkbook.Name, , "Active Workbook Name:" ActiveWorkbook.Close False Next f End Sub

kitap açma (tek dosya)

ID : 1327
ISLEM : kitap açma (tek dosya)
MAKRO KODU : Sub OpenOneFile() Dim fn As Variant fn = Application.GetOpenFilename("Excel-files,*.xls", _ 1, "Select One File To Open", , False) If TypeName(fn) = "Boolean" Then Exit Sub Debug.Print "Selected file: " & fn Workbooks.Open fn End Sub

kitap adını a1 e aldırma

ID : 1328
ISLEM : kitap adını a1 e aldırma
MAKRO KODU : Sub kitap_ismi() Sheets("Sayfa1").Range("A1").Value = ThisWorkbook.FullName End Sub

kitap başlığı isimlendirme (caption)

ID : 1329
ISLEM : kitap başlığı isimlendirme (caption)
MAKRO KODU : Public AppCap$ Public ActWinCap$ 'Titelleiste ändern, wenn Mappe aktiviert wird Private Sub Workbook_Activate() Application.Caption = "excel-lex" ActiveWindow.Caption = "http://www.excel-lex.de.vu: Das EXCEL-2000-Lexikon ©2003 K.-M. Buss" End Sub 'Titelleiste zurücksetzen, wenn diese geschlossen wird Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub 'Titelleiste zurücksetzen, wenn diese deaktiviert wird Private Sub Workbook_Deactivate() Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub 'Titelleiste ändern, wenn Mappe geöffnet wird Private Sub Workbook_Open() Application.Caption = "excel-lex" ActiveWindow.Caption = "http://www.excel-lex.de.vu: Das EXCEL-2000-Lexikon ©2003 K.-M. Buss" End Sub

kitap her açılışta a1 1 artar

ID : 1330
ISLEM : kitap her açılışta a1 1 artar
MAKRO KODU : Sub Workbook_Open() With Worksheets(1).Range("A1") .Value = .Value + 1 End With End Sub

kitap ismi ile klasör oluşturur her sayfayı ayrı ayrı olarak kaydet

ID : 1331
ISLEM : kitap ismi ile klasör oluşturur her sayfayı ayrı ayrı olarak kaydet
MAKRO KODU : Option Explicit Sub sayfalari_ayir_kaydet() Dim Sheet As Worksheet, SheetName$, MyFilePath$, N& MyFilePath$ = ActiveWorkbook.Path & "\" & _ Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For N = 1 To Sheets.Count Sheets(N).Activate SheetName = ActiveSheet.Name Cells.Copy Workbooks.Add (xlWBATWorksheet) With ActiveWorkbook With .ActiveSheet .Paste .Name = SheetName [A1].Select End With .SaveAs Filename:=MyFilePath _ & "\" & SheetName & ".xls" .Close SaveChanges:=True End With .CutCopyMode = False Next End With Sayfa1.Activate End Sub

kitap kaç kere açılmış

ID : 1332
ISLEM : kitap kaç kere açılmış
MAKRO KODU : Sub auto_open() Worksheets("Sheet2").Range("A1") = Worksheets("Sheet2").Range("A1") + 1 End Sub

kitap kapanırken a1 e tarih ekleme

ID : 1333
ISLEM : kitap kapanırken a1 e tarih ekleme
MAKRO KODU : Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Range("A1").Value = "Stand: " & Format(Date, "DD.MM.YYYY") Worksheets("Tabelle1").PageSetup.LeftFooter = "Stand: " & Format(Date, "DD.MM.YYYY") End Sub

kitap kaydet ismini sen belirle - mesajla bildirir

ID : 1334
ISLEM : kitap kaydet ismini sen belirle - mesajla bildirir
MAKRO KODU : Sub ShowFileSaveAsDialog() Workbooks.Add ' create a new workbook With Worksheets(1).Range("A1") ' add information to the new workbook .Formula = "Log File for " & Format(Date, "yyyy-mm-dd") & ":" .Font.Size = 14 .Font.Bold = True End With Application.Dialogs(xlDialogSaveAs).Show ' display the Save as dialog If Len(ActiveWorkbook.Path) = 0 Then ' the workbook was not saved MsgBox "You can save the workbook manually later..." Else MsgBox "The workbook is saved as " & ActiveWorkbook.FullName End If End Sub

kitap kaydetme ismini belirli

ID : 1335
ISLEM : kitap kaydetme ismini belirli
MAKRO KODU : Sub SaveOneFile() Dim fn As Variant fn = Application.GetSaveAsFilename("MyFileName.xls", _ "Excel files,*.xls", 1, "Select your folder and filename") If TypeName(fn) = "Boolean" Then Exit Sub ActiveWorkbook.SaveAs fn End Sub

kitap penceresini 2 boyut küçültme

ID : 1336
ISLEM : kitap penceresini 2 boyut küçültme
MAKRO KODU : Sub InTheMiddle() Dim dWidth As Double, dHeight As Double With Application .WindowState = xlMaximized dWidth = .Width dHeight = .Height .WindowState = xlNormal .Top = dHeight / 4 .Height = dHeight / 2 .Left = dWidth / 4 .Width = dWidth / 2 End With End Sub

kitap sayfasını simge durumunda küçültme

ID : 1337
ISLEM : kitap sayfasını simge durumunda küçültme
MAKRO KODU : Private Sub CmdIntro_Click() ActiveWindow.WindowState = xlMinimized End Sub

kitap toplam kaç kere,hangi tarih ve hangi saatte açıldı

ID : 1338
ISLEM : kitap toplam kaç kere,hangi tarih ve hangi saatte açıldı
MAKRO KODU : This workbook bölümüne; Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String Counter = GetSetting("XYZ Corp", "Budget", "Count", 0) LastOpen = GetSetting("XYZ Corp", "Budget", "Opened", "") Msg = "Çalışma kitabı " & Counter & " kere açıldı." Msg = Msg & vbCrLf & "En son açılış: " & LastOpen MsgBox Msg, vbInformation, ThisWorkbook.Name Counter = Counter + 1 LastOpen = Date & " " & Time SaveSetting "XYZ Corp", "Budget", "Count", Counter SaveSetting "XYZ Corp", "Budget", "Opened", LastOpen End Sub

kitap yedekleme

ID : 1339
ISLEM : kitap yedekleme
MAKRO KODU : Sub SaveWorkbookBackup() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub Set awb = ActiveWorkbook If awb.path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.FullName i = 0 While InStr(i + 1, BackupFileName, ".") > 0 i = InStr(i + 1, BackupFileName, ".") Wend If i > 0 Then BackupFileName = Left(BackupFileName, i - 1) BackupFileName = BackupFileName & ".bak" OK = False On Error GoTo NotAbleToSave With awb Application.StatusBar = "Saving this workbook..." .Save Application.StatusBar = "Saving this workbook backup..." .SaveCopyAs BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox "Backup Copy Not Saved!", vbExclamation, ThisWorkbook.Name End If End Sub,

kitapta istenilen sayfa adını önizlemek için

ID : 1340
ISLEM : kitapta istenilen sayfa adını önizlemek için
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) ActiveSheet.PageSetup.RightFooter = ActiveWorkbook.FullName End Sub

kitapta ne kadar formül varsa ayrıntılı olarak belirtir (yeni sayfada)

ID : 1341
ISLEM : kitapta ne kadar formül varsa ayrıntılı olarak belirtir (yeni sayfada)
MAKRO KODU : Option Explicit Public Sub ListFormulasInWorkbook() ' by J.E. McGimpsey ' revised 04 July 2003 by Tom Ogilvy to add ' sheets when reaching ROWLIM formulas Const SHEETNAME As String = "Formulas in *" Const ALLFORMULAS As Integer = _ xlNumbers + xlTextValues + xlLogical + xlErrors Const ROWLIM As Long = 65500 Dim formulaSht As Worksheet Dim destRng As Range Dim cell As Range Dim wkSht As Worksheet Dim formulaRng As Range Dim shCnt As Long Dim oldScreenUpdating As Boolean With Application oldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With shCnt = 0 ListFormulasAddSheet formulaSht, shCnt ' list formulas on each sheet Set destRng = formulaSht.Range("A4") For Each wkSht In ActiveWorkbook.Worksheets If Not wkSht.Name Like SHEETNAME Then Application.StatusBar = wkSht.Name destRng.Value = wkSht.Name Set destRng = destRng.Offset(1, 0) On Error Resume Next Set formulaRng = wkSht.Cells.SpecialCells( _ xlCellTypeFormulas, ALLFORMULAS) On Error GoTo 0 If formulaRng Is Nothing Then destRng.Offset(0, 1).Value = "None" Set destRng = destRng.Offset(1, 0) Else For Each cell In formulaRng With destRng .Offset(0, 1) = cell.Address(0, 0) .Offset(0, 2) = "'" & cell.Formula .Offset(0, 3) = cell.Value End With Set destRng = destRng.Offset(1, 0) If destRng.row > ROWLIM Then ListFormulasAddSheet formulaSht, shCnt Set destRng = formulaSht.Range("A5") destRng.Offset(-1, 0).Value = wkSht.Name End If Next cell Set formulaRng = Nothing End If With destRng.Resize(1, 4).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) If destRng.row > ROWLIM Then ListFormulasAddSheet formulaSht, shCnt Set destRng = formulaSht.Range("A5") destRng.Offset(-1, 0).Value = wkSht.Name End If End If Next wkSht With Application .StatusBar = False .ScreenUpdating = oldScreenUpdating End With End Sub Private Sub ListFormulasAddSheet( _ formulaSht As Worksheet, shtCnt As Long) Const SHEETNAME As String = "Formulas in " Const SHEETTITLE As String = "Formulas in $ as of " Const DATEFORMAT As String = "dd MMM yyyy hh:mm" Dim shtName As String With ActiveWorkbook ' Delete existing sheet and create new one shtCnt = shtCnt + 1 shtName = Left(SHEETNAME & .Name, 28) If shtCnt > 1 Then _ shtName = shtName & "_" & shtCnt On Error Resume Next Application.DisplayAlerts = False .Worksheets(shtName).Delete Application.DisplayAlerts = True On Error GoTo 0 Set formulaSht = .Worksheets.Add( _ after:=Sheets(Sheets.Count)) End With With formulaSht ' Format headers .Name = shtName .Columns(1).ColumnWidth = 15 .Columns(2).ColumnWidth = 8 .Columns(3).ColumnWidth = 60 .Columns(4).ColumnWidth = 40 With .Range("C:D") .Font.Size = 9 .HorizontalAlignment = xlLeft .EntireColumn.WrapText = True End With With .Range("A1") .Value = Application.Substitute(SHEETTITLE, "$", _ ActiveWorkbook.Name) & Format(Now, DATEFORMAT) With .Font .Bold = True .ColorIndex = 5 .Size = 14 End With End With With .Range("A3").Resize(1, 4) .Value = Array("Sheet", "Address", "Formula", "Value") With .Font .ColorIndex = 13 .Bold = True .Size = 12 End With .HorizontalAlignment = xlCenter With .Borders(xlEdgeBottom) .LineStyle = xlDouble .Weight = xlThick .ColorIndex = 5 End With End With End With End Sub

kitapta ne kadar refers varsa ayrıntılı olarak belirtir (yeni sayfada)

ID : 1342
ISLEM : kitapta ne kadar refers varsa ayrıntılı olarak belirtir (yeni sayfada)
MAKRO KODU : Option Explicit Public Sub ListNamesInWorkbook() ' by J.E. McGimpsey ' Thanks to Tom Ogilvy for help with overflow. Const SHEETNAME As String = "Names in *" Const ROWLIM As Long = 65500 Dim nameSht As Worksheet Dim destRng As Range Dim cell As Range Dim wkSht As Worksheet Dim shCnt As Long Dim i As Long Dim oldScreenUpdating As Boolean With Application oldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With shCnt = 0 ListNamesAddSheet nameSht, shCnt ' list Workbook-level names Set destRng = nameSht.Range("A5") With destRng.Offset(-1, 0) .Value = "Workbook-Level names" .Font.Bold = True End With With ActiveWorkbook.Names If .Count Then destRng.Offset(0, 1).ListNames 'only workbook level Set destRng = destRng.Offset(0, 1).End(xlDown).Offset(1, -1) Else destRng.Offset(0, 1).Value = "None" Set destRng = destRng.Offset(0, 1) End If End With With destRng.Resize(1, 3).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) For Each wkSht In ActiveWorkbook.Worksheets With destRng .Value = "Names in sheet """ & wkSht.Name & """" .Font.Bold = True Set destRng = .Offset(1, 0) End With With wkSht.Names If .Count Then For i = 1 To .Count With .Item(i) destRng.Offset(0, 1) = Mid(.Name, InStr(.Name, "!") + 1) destRng.Offset(0, 2) = "'" & .RefersTo Set destRng = destRng.Offset(1, 0) If destRng.Row > ROWLIM Then ListNamesAddSheet nameSht, shCnt Set destRng = nameSht.Range("A5") destRng.Offset(-1, 0).Value = _ "Names in sheet """ & wkSht.Name & """" End If End With Next i Else destRng.Offset(0, 1).Value = "None" Set destRng = destRng.Offset(1, 0) End If End With With destRng.Resize(1, 4).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) Next wkSht With Application .StatusBar = False .ScreenUpdating = oldScreenUpdating End With End Sub Private Sub ListNamesAddSheet( _ nameSht As Worksheet, shtCnt As Long) Const SHEETNAME As String = "Names in " Const SHEETTITLE As String = "Names in $ as of " Const DATEFORMAT As String = "dd MMM yyyy hh:mm" Dim shtName As String With ActiveWorkbook ' Delete existing sheet and create new one shtName = Left(SHEETNAME & .Name, 28) shtCnt = shtCnt + 1 If shtCnt > 1 Then _ shtName = shtName & "_" & Format(shtCnt, "00") On Error Resume Next Application.DisplayAlerts = False .Worksheets(shtName).Delete Application.DisplayAlerts = True On Error GoTo 0 Set nameSht = .Worksheets.Add( _ after:=Sheets(Sheets.Count)) End With With nameSht ' Format headers .Name = shtName .Columns(1).ColumnWidth = 30 .Columns(2).ColumnWidth = 20 .Columns(3).ColumnWidth = 90 With .Range("B:C") .Font.Size = 9 .HorizontalAlignment = xlLeft .EntireColumn.WrapText = True End With With .Range("A1") .Value = Application.Substitute(SHEETTITLE, "$", _ ActiveWorkbook.Name) & Format(Now, DATEFORMAT) With .Font .Bold = True .ColorIndex = 5 .Size = 14 End With End With With .Range("A3").Resize(1, 3) .Value = Array("Sheet", "Name", "Refers To") With .Font .ColorIndex = 13 .Bold = True .Size = 12 End With .HorizontalAlignment = xlCenter With .Borders(xlEdgeBottom) .LineStyle = xlDouble .Weight = xlThick .ColorIndex = 5 End With End With End With End Sub

kitapta yazdırmayı iptal etme

ID : 1343
ISLEM : kitapta yazdırmayı iptal etme
MAKRO KODU : Sub Auto_Open() 'Prevent Printing via menu MenuBars(xlWorksheet).Menus("File").MenuItems("Print...").Delete 'Turn off Print icon wherever it may be in the toolbars For J = 1 To Toolbars.Count For K = 1 To Toolbars(J).ToolbarButtons.Count If Toolbars(J).ToolbarButtons(K).Id = 2 Then Toolbars(J).ToolbarButtons(K).Enabled = False End If If Toolbars(J).ToolbarButtons(K).Id = 3 Then Toolbars(J).ToolbarButtons(K).Enabled = False End If Next K Next J End Sub Sub Auto_Close() 'Reset the menu items For Each mb In MenuBars mb.Reset Next mb 'Reset the buttons For J = 1 To Toolbars.Count For K = 1 To Toolbars(J).ToolbarButtons.Count If Toolbars(J).ToolbarButtons(K).Id = 2 Then Toolbars(J).ToolbarButtons(K).Enabled = True End If If Toolbars(J).ToolbarButtons(K).Id = 3 Then Toolbars(J).ToolbarButtons(K).Enabled = True End If Next K Next J End Sub Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True End Sub

kitaptaki tüm resimleri silme

ID : 1344
ISLEM : kitaptaki tüm resimleri silme
MAKRO KODU : Sub DeleteShapes() Dim wks As Worksheet For Each wks In Worksheets wks.Pictures.Delete Next wks End Sub

klasör açma

ID : 1345
ISLEM : klasör açma
MAKRO KODU : Private Sub Command1_Click() Dim a a = Shell("C:\WINDOWS\Explorer.exe c:\windows", vbNormalFocus) End Sub

klasör alma

ID : 1346
ISLEM : klasör alma
MAKRO KODU : Sub Klasör_Al() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.GetFolder("D:\ExcelÖrnekleri") End Sub

klasör arama

ID : 1347
ISLEM : klasör arama
MAKRO KODU : Sub klasör_ara() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.FolderExists("C:\SXSİ") If a = True Then MsgBox "Bu isimde bir klasör var" Else MsgBox "Bu isimde bir klasör yok" End If End Sub

klasör bilgisi

ID : 1348
ISLEM : klasör bilgisi
MAKRO KODU : Sub Klasör_Bilgisi_Göster() Dim ds, f, s Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.GetFolder("D:\ExcelÖrnekleri") s = UCase("D:\ExcelÖrnekleri") & vbCrLf s = s & "Created: " & f.DateCreated & vbCrLf 'Oluşturma s = s & "Last Accessed: " & f.DateLastAccessed & vbCrLf 'Son Erişim s = s & "Last Modified: " & f.DateLastModified 'Son Değiştirilme MsgBox s, 0, "File Access Info" End Sub

klasör ismi değiştirme

ID : 1349
ISLEM : klasör ismi değiştirme
MAKRO KODU : Sub Klasör_İsmi_Değiştir() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") dosya = ds.GetFileName("D:\ExcelÖrnekleri\Yeni") dosya2 = ds.GetFileName("C:\SXS") f = ds.MoveFolder(dosya, dosya2) End Sub

klasör oluşturma

ID : 1350
ISLEM : klasör oluşturma
MAKRO KODU : Sub Klasör_Oluştur() Dim ds Set ds = CreateObject("Scripting.FileSystemObject") ds.CreateFolder "C:\SXS\Deneme" End Sub

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