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


kdv hesaplatma

ID : 1291
ISLEM : kdv hesaplatma
MAKRO KODU : Private Sub Command1_Click() Dim a, sonuc As Integer a = InputBox("ÜCRETİ GİRİNİZ") If a > 0 Then sonuc = a * 1.18 MsgBox sonuc End If End Sub

kdv hesaplatma 2

ID : 1292
ISLEM : kdv hesaplatma 2
MAKRO KODU : Private Sub Command1_Click() Dim a, sonuc As Integer a = InputBox("ÜCRETİ GİRİNİZ") If a > 0 Then sonuc = a * 1.18 MsgBox sonuc End If End Sub

kelimeler arasında 1 space boşluğu bırakır

ID : 1293
ISLEM : kelimeler arasında 1 space boşluğu bırakır
MAKRO KODU : Sub BereichGlaetten() Dim r As Range, c As Range On Error Resume Next Set r = Application.InputBox("Bereich markieren, der geglättet werden soll: ", Type:=8) For Each c In r.Cells c.Value = Application.WorksheetFunction.Trim(c.Value) Next c End Sub

kenarlık penceresi

ID : 1294
ISLEM : kenarlık penceresi
MAKRO KODU : Sub Dialog_08() Application.Dialogs(xlDialogBorder).Show End Sub

kendi kendine kapanan kitap 10 sn de

ID : 1295
ISLEM : kendi kendine kapanan kitap 10 sn de
MAKRO KODU : Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) Zurücksetzen End Sub Private Sub Workbook_Open() startzeit End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) startzeit End Sub 'Modüle Dim DaA As Date Sub startzeit() On Error Resume Next Application.OnTime EarliestTime:=DaA, Procedure:="Schließen", Schedule:=False DaA = Now + CDate("0:00:10") Application.OnTime DaA, "Schließen" End Sub Sub Schließen() ThisWorkbook.Close True End Sub Sub Zurücksetzen() Application.OnTime EarliestTime:=DaA, Procedure:="Schließen", Schedule:=False End Sub

kendi kendine kapanan kitap 10 sn de mükemmel

ID : 1296
ISLEM : kendi kendine kapanan kitap 10 sn de mükemmel
MAKRO KODU : Thisworkbooka Private Sub Workbook_Open() DaZeit = "0:00:10" ThisWorkbook.Worksheets("Tabelle1").Range("A1") = CDate(DaZeit) Zeitmakro End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.OnTime EarliestTime:=VaEt, Procedure:="Zeitmakro", Schedule:=False End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ThisWorkbook.Worksheets("Tabelle1").Range("A1") = DaZeit End Sub 'Modüle Sub Zeitmakro() ' ThisWorkbook.Worksheets("Tabelle1").Range("A1") = ThisWorkbook.Worksheets("Tabelle1").Range("A1") - CDate("00:00:01") If ThisWorkbook.Worksheets("Tabelle1").Range("A1") 0 Then VaEt = Now + TimeValue("00:00:01") Application.OnTime VaEt, "Zeitmakro" Else ThisWorkbook.Close True 'speichern ' Meldung bei Excel immer in Vordergrund ' Dim mldg ' mldg = MsgBox("Endzeit erreicht", 1048576, "Endzeit") ' 1048576 entspricht vbMsgBoxRtlReading End If End Sub -

kes kopyalayı iptal etmek & aç

ID : 1297
ISLEM : kes kopyalayı iptal etmek & aç
MAKRO KODU : Kullanıcıların çalışma kitabını açtıklarında kesme/kopyalama ve yapıştırma komutlarını kullanamaz. Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey "^c", "" Application.OnKey "^v", "" Application.OnKey "+{DEL}", "" Application.OnKey "+{INSERT}", "" Application.CellDragAndDrop = False End Sub ' BU KOD KISITLAMALARI AKTİF YAPAR Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey "^c" Application.OnKey "^v" Application.OnKey "+{DEL}" Application.OnKey "+{INSERT}" Application.CellDragAndDrop = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub

kes kopyalayi iptal et & aç

ID : 1298
ISLEM : kes kopyalayi iptal et & aç
MAKRO KODU : Kullanıcıların çalışma kitabını açtıklarında kesme/kopyalama ve yapıştırma komutlarını kullanamaz. Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey "^c", "" Application.OnKey "^v", "" Application.OnKey "+{DEL}", "" Application.OnKey "+{INSERT}", "" Application.CellDragAndDrop = False End Sub ' BU KOD KISITLAMALARI AKTİF YAPAR Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey "^c" Application.OnKey "^v" Application.OnKey "+{DEL}" Application.OnKey "+{INSERT}" Application.CellDragAndDrop = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub

kesme, kopyala, yapıştır etkin

ID : 1299
ISLEM : kesme, kopyala, yapıştır etkin
MAKRO KODU : Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey "^c" Application.OnKey "^v" Application.OnKey "+{DEL}" Application.OnKey "+{INSERT}" Application.CellDragAndDrop = True End Sub

kesme, kopyala, yapıştır iptal

ID : 1300
ISLEM : kesme, kopyala, yapıştır iptal
MAKRO KODU : Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey "^c", "" Application.OnKey "^v", "" Application.OnKey "+{DEL}", "" Application.OnKey "+{INSERT}", "" Application.CellDragAndDrop = False End Sub

kırmızı renkli sayıyı seç g12 ye yazsın

ID : 1301
ISLEM : kırmızı renkli sayıyı seç g12 ye yazsın
MAKRO KODU : Sub sommeCouleurRougeText() Dim Cellule As Range Dim total As Variant For Each Cellule In Selection If Cellule.Font.ColorIndex = 3 Then '3 rouge et 1 pour le noir 'If Cellule.Interior.ColorIndex = 3 Then (pour la couleur de fond) If IsNumeric(Cellule) Then total = total + Cellule.Value End If Next MsgBox total Range("G12") = total End Sub

kısayol tuşları listesi

ID : 1302
ISLEM : kısayol tuşları listesi
MAKRO KODU : Option Explicit Sub StartList() Dim R As Range ActiveSheet.UsedRange.ClearContents Set R = Range("A3") ListCtrls Application.CommandBars.ActiveMenuBar, R End Sub Sub ListCtrls(Ctrl As Object, Rng As Range) Dim C As Office.CommandBarControl Static S As String Dim Pos As Integer If TypeOf Ctrl Is CommandBar Then S = "ALT" End If If Not TypeOf Ctrl Is Office.CommandBarButton Then For Each C In Ctrl.Controls Rng.Value = C.Caption Pos = InStr(1, C.Caption, "&") If Pos Then S = S & "+" & Mid(C.Caption, Pos + 1, 1) Rng.EntireRow.Cells(1, "H").Value = UCase(S) End If Set Rng = Rng(2, 2) ListCtrls C, Rng Set Rng = Rng(1, 0) If Len(S) > 3 Then S = Left(S, Len(S) - 2) End If Next C End If

kitabı açma-kopyalama-kapama

ID : 1303
ISLEM : kitabı açma-kopyalama-kapama
MAKRO KODU : Sub dosyaaç() Workbooks.Open Filename:="C:\Belgelerim\kitap1.xls" End Sub Sub kopyala() Sheets("Sayfa1").Copy After:=Workbooks("Kitap1").Sheets(1) End Sub Sub dosyakapat() Workbooks("kitap1.xls").Close End Sub

kitabı belirlenen isimle kayıt etme

ID : 1304
ISLEM : kitabı belirlenen isimle kayıt etme
MAKRO KODU : Sub test() UsrRsp = Application.Dialogs(xlDialogSaveAs).Show("test.xls") Select Case UsrRsp Case -1 Case 0 End Select End Sub

kitabı diskete yedekleme

ID : 1305
ISLEM : kitabı diskete yedekleme
MAKRO KODU : Sub SaveWorkbookBackupToFloppyA() 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.Name OK = False On Error GoTo NotAbleToSave If Dir("A:\" & BackupFileName) "" Then Kill "A:\" & BackupFileName End If With awb Application.StatusBar = "Saving this workbook..." .Save Application.StatusBar = "Saving this workbook backup..." .SaveCopyAs "A:\" & 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 -

kitabı isimle kaydetme

ID : 1306
ISLEM : kitabı isimle kaydetme
MAKRO KODU : Sub Save() ActiveWorkbook.Save End Sub Sub SaveName() ActiveWorkbook.SaveAs Filename:="C:\MyFile.xls" End Sub

kitabı kapat, kaydet

ID : 1307
ISLEM : kitabı kapat, 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

kitabı kapatırken a1 hücresine tarihi yaz

ID : 1308
ISLEM : kitabı kapatırken a1 hücresine tarihi yaz
MAKRO KODU : Private Sub Workbook_BeforeClose(Cancel As Boolean) Sheets(1).[A1] = "Dernière modification le " & Format(Date, "dd/mm/yyyy") End Sub

kitabı kaydederken mesaj alma

ID : 1309
ISLEM : kitabı kaydederken mesaj alma
MAKRO KODU : Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _ Cancel As Boolean) a = MsgBox("Bu kitabı gerçetken kaydetmek istiyor musunuz?", vbYesNo) If a = vbNo Then Cancel = True End Sub

kitabı kaydet pencereyi kapat, a1'i seç:

ID : 1310
ISLEM : kitabı 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

kitabı kilitleme. salt okunur olarak açma. makroları gizler

ID : 1311
ISLEM : kitabı kilitleme. salt okunur olarak açma. makroları gizler
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

kitabı otomatik kaydedip kapatma

ID : 1312
ISLEM : kitabı otomatik kaydedip kapatma
MAKRO KODU : Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.DisplayAlerts = False ActiveWorkbook.Save Application.DisplayAlerts = True End Sub

kitabı yedekleme

ID : 1313
ISLEM : kitabı 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

kitabın adını öğrenme

ID : 1314
ISLEM : kitabın adını öğrenme
MAKRO KODU : Sub Dateiname() MsgBox ActiveWorkbook.Name End Sub

kitabın başlığını değiştirme

ID : 1315
ISLEM : kitabın başlığını değiştirme
MAKRO KODU : Sub test() Application.Caption = "Excelci" ActiveWindow.Caption = "pirr" 'Incorrect MsgBox Application.Caption & " " & ActiveWindow.Caption 'Correct MsgBox Application.Caption End Sub

kitabın boyutunu hesaplasın

ID : 1316
ISLEM : kitabın boyutunu hesaplasın
MAKRO KODU : Sub Taillefile() Dim SizeFile SizeFile = FileLen("c:\ajeter\classeur1.xls") MsgBox "Taille du fichier " & SizeFile & " octets" 'du classeur actif MsgBox FileLen(ThisWorkbook.FullName) & " octets" End Sub

kitabın bulunduğu yolu ve ismini belirtir

ID : 1317
ISLEM : kitabın bulunduğu yolu ve ismini belirtir
MAKRO KODU : Function FileOrFolderName(InputString As String, _ ReturnFileName As Boolean) As String Dim i As Integer, FolderName As String, FileName As String i = 0 While InStr(i + 1, InputString, Application.PathSeparator) > 0 i = InStr(i + 1, InputString, Application.PathSeparator) Wend If i = 0 Then FolderName = CurDir Else FolderName = Left(InputString, i - 1) End If FileName = Right(InputString, Len(InputString) - i) If ReturnFileName Then FileOrFolderName = FileName Else FileOrFolderName = FolderName End If End Function Sub TestFileOrFolderName() MsgBox FileOrFolderName(ThisWorkbook.FullName, False), , _ "This Workbook Foldername:" MsgBox FileOrFolderName(ThisWorkbook.FullName, True), , _ "This Workbook Filename:" End Sub

kitabın ilk kaydediliş tarihini yazar

ID : 1318
ISLEM : kitabın ilk kaydediliş tarihini yazar
MAKRO KODU : Sub LetztesSpeicherdatumEintragen() Range("A1").Value = _ ActiveWorkbook.BuiltinDocumentProperties("Last Save Time").Value End Sub

kitabın kopyasını userform,modul,class silerek oluşturur

ID : 1319
ISLEM : kitabın kopyasını userform,modul,class silerek oluşturur
MAKRO KODU : Sub SaveWithoutMacros() Dim vFilename As Variant Dim wbActiveBook As Workbook Dim oVBComp As Object Dim oVBComps As Object On Error GoTo CodeError vFilename = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbooks,*.xls", _ Title:="Save Copy Without Macros") If vFilename = False Then Exit Sub ActiveWorkbook.SaveCopyAs vFilename Set wbActiveBook = Workbooks.Open(vFilename) Set oVBComps = wbActiveBook.VBProject.VBComponents For Each oVBComp In oVBComps Select Case oVBComp.Type Case 1, 2, 3 oVBComps.Remove oVBComp Case Else With oVBComp.CodeModule .DeleteLines 1, .CountOfLines End With End Select Next oVBComp wbActiveBook.Save MsgBox "Vba kodlarınız silinerek çalışma kitabınızın kopyası oluşturuldu!.", vbInformation, "pir" Exit Sub CodeError: MsgBox Err.Description, vbExclamation, "Başarısız" End Sub

kitabınızı diskete yedekler

ID : 1320
ISLEM : kitabınızı diskete yedekler
MAKRO KODU : Sub SaveWorkbookBackupToFloppyA() 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.Name OK = False On Error GoTo NotAbleToSave If Dir("A:\" & BackupFileName) "" Then Kill "A:\" & BackupFileName End If With awb Application.StatusBar = "Saving this workbook..." .Save Application.StatusBar = "Saving this workbook backup..." .SaveCopyAs "A:\" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox "Dosya Yedeklenemedi!", vbExclamation, ThisWorkbook.Name End If End Sub -

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