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


optionbuttonlarin işaretini kaldirmak

ID : 1591
ISLEM : optionbuttonlarin işaretini kaldirmak
MAKRO KODU : Aşağıdaki gibi bir kodla kaldırabilirsiniz. visual basic kodu: -------------------------------------------------------------------------------- OptionButton1.Value = False OptionButton2.Value = False . . .

optionbuttonun özelliğini textboxa yazdırmak

ID : 1592
ISLEM : optionbuttonun özelliğini textboxa yazdırmak
MAKRO KODU : Private Sub OptionButton2_Click() If OptionButton2.Value = True Then 'işaretlediğinde manuel girmesinler diye TextBox10.Enabled = False TextBox10.Value = "Döküman" Else TextBox10.Value = Empty End If End Sub Private Sub OptionButton1_Click() 'manuel girmeleri için true TextBox10.Enabled = True TextBox10.Value = "" End Sub

otomatik cümle yazar

ID : 1593
ISLEM : otomatik cümle yazar
MAKRO KODU : Açıklama: Çalışma Sayfanızda herhangi bir hücreye 1 yazdığınızda bire karşılık gelen Cümle otomatik yazılır (En hızlı siz yazacaksınız ) Kod: Private Sub Worksheet_Change(ByVal Target As Excel.Range) If IsEmpty(Target) Then Exit Sub If Target = "1" Then Target = "İlçe Milli EĞitim Müdürlüğü" If Target = "2" Then Target = "Ahmet Aşkın KÜÇÜKKAYA" If Target = "3" Then Target = "Ordu İli Kabataş İlçesi" If Target = "4" Then Target = "Kabataş" End Sub

otomatik düzelt penceresi

ID : 1594
ISLEM : otomatik düzelt penceresi
MAKRO KODU : Sub Dialog_07() Application.Dialogs(xlDialogAutoCorrect).Show End Sub

otomatik hesaplama etkin-etkisiz

ID : 1595
ISLEM : otomatik hesaplama etkin-etkisiz
MAKRO KODU : Sub Makro2() With Application .Calculation = xlManual End With End Sub Sub Makro3() With Application .Calculation = xlAutomatic End With End Sub Sub Makro4() Calculate End Sub

otomatik makro her 10 saniyede

ID : 1596
ISLEM : otomatik makro her 10 saniyede
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

otomatik makro kayit

ID : 1597
ISLEM : otomatik makro kayit
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$B$8" And Target.Value = 20 Then Cells.Select Selection.Copy Worksheets.Add.Name = Range("A4") ActiveSheet.Paste ActiveWorkbook.Save End If End Sub

otomatik süz ile alttoplam

ID : 1598
ISLEM : otomatik süz ile alttoplam
MAKRO KODU : =ALTTOPLAM(9;B3:B1000)

otomatik süzü (filtreyi) aç

ID : 1599
ISLEM : otomatik süzü (filtreyi) aç
MAKRO KODU : Sub FilterAufheben() If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End Sub

otomatik süzü açtırma

ID : 1600
ISLEM : otomatik süzü açtırma
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) CommandButton1.Caption = Range("A1").Value & Chr(13) & Chr(13) & " gefilterte Zeilen" End Sub 'sayfadaki buton bura ile ilişkilendirilecek Private Sub CommandButton1_Click() Filter_setzen CommandButton1.Caption = Range("A1").Value & Chr(13) & Chr(13) & " gefilterte Zeilen" End Sub 'modüle Sub Filter_setzen() Range("c1").Select SendKeys "%{Down}" Range("D1").Select Range("C1").Select End Sub

önizleme makrosu

ID : 1601
ISLEM : önizleme makrosu
MAKRO KODU : Me.Hide Sheets("test").Select ActiveWindow.SelectedSheets.PrintPreview Me.Show

önizlemesiz a5 kaüıttan çıktı alma

ID : 1602
ISLEM : önizlemesiz a5 kaüıttan çıktı alma
MAKRO KODU : Private Sub CommandButton1_Click() Sheets("Sayfa1").Select With ActiveSheet.PageSetup .PaperSize = xlPaperA5: .CenterHorizontally = True: .Orientation = xlPortrait .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1 End With Unload Me ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub

önizlemesiz yazdırma

ID : 1603
ISLEM : önizlemesiz yazdırma
MAKRO KODU : Private Sub CommandButton1_Click() Sheets("Sayfa1").Select With ActiveSheet.PageSetup .PaperSize = xlPaperA5: .CenterHorizontally = True: .Orientation = xlPortrait .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1 End With Unload Me ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub

özel altbilgi sayfa1 de sol alt köşede kitap ismi

ID : 1604
ISLEM : özel altbilgi sayfa1 de sol alt köşede kitap ismi
MAKRO KODU : Sub Dateipfad() Worksheets(1).PageSetup.LeftFooter = ThisWorkbook.FullName End Sub

özel gider iindirimi makrosu

ID : 1605
ISLEM : özel gider iindirimi makrosu
MAKRO KODU : Function iade2005(tutar) iade2005 = Round(Switch(tutar > 6600, (tutar - 6600) * 0.04 + 462, tutar > 3300, (tutar - 3300) * 0.06 + 264, tutar -

özel görünümler penceresi

ID : 1606
ISLEM : özel görünümler penceresi
MAKRO KODU : Sub Dialog_19() Application.Dialogs(xlDialogCustomViews).Show End Sub

özelaltbilgi sağda dosya yolu, sağda kitap ismi

ID : 1607
ISLEM : özelaltbilgi sağda dosya yolu, sağda kitap ismi
MAKRO KODU : Sub Pied_Page() Dim Repert As String Dim Fichier As String Repert = ActiveWorkbook.Path Fichier = ActiveWorkbook.Name With ActiveSheet.PageSetup .LeftFooter = Repert .RightFooter = Fichier End With End Sub

para formatı

ID : 1608
ISLEM : para formatı
MAKRO KODU : Sub Euro() Selection.NumberFormat = "#,##0.00 " & ChrW(8364) End Sub Sub Euro0() Selection.NumberFormat = "#,##0 " & ChrW(8364) End Sub Sub EuroRot() Selection.NumberFormat = "#,##0.00 " & ChrW(8364) & " ;[RED]-#,##0.00 " & _ ChrW(8364) End Sub

parça al fonksiyonu macro olarak hazirlamak

ID : 1609
ISLEM : parça al fonksiyonu macro olarak hazirlamak
MAKRO KODU : aşağıdaki kod işinizi görecektir. Kod: For i = 2 To Cells(65536, 1).End(xlUp).Row son = 1 For j = 2 To Cells(1, 1).End(xlToRight).Column Cells(i, j) = Mid(Cells(i, 1), son, Cells(1, j)) son = son + Cells(1, j) Next j Next i yapmanız gereken a2 den itibaren aşağı doğru verilerinizi yapıştırmak. ve b1, c1, d1, e1 ....... gerektiği kadar alınması gereken parça boyutlarını girmek. yukarıdaki kodu şekilde görülen butonun içine yapıştırın.

parola değiştirme farklı kaydetle

ID : 1610
ISLEM : parola değiştirme farklı kaydetle
MAKRO KODU : Sub FarkliKaydet() 'Application.DisplayAlerts = False Workbooks(ActiveWorkbook.Name).SaveAs Filename:=ThisWorkbook.FullName, FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _ False, CreateBackup:=True 'Application.DisplayAlerts = True End Sub

partisyon belirt ne kadar dosya varsa listelesin

ID : 1611
ISLEM : partisyon belirt ne kadar dosya varsa listelesin
MAKRO KODU : Option Explicit Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Const MAX_PATH = 260 Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private nCount& 'Main code ================= Private Sub GetDirectoryListing(ByVal Root$) ' Function to calculate bytes used in Root$ and all subdirectories of Root$. ' Root$ should be entered in the form c:\Dir Dim FData As WIN32_FIND_DATA Dim fHand& Dim sPath$ Dim StillOK& Dim ByteTotal& Dim nPos% Dim DirName$, FileName$ sPath$ = Root$ + "\*.*" fHand& = FindFirstFile(sPath$, FData) If fHand& "." And DirName$ ".." Then GetDirectoryListing Root$ + "\" + DirName$ End If Else nCount& = nCount& + 1 nPos% = InStr(FData.cFileName, Chr$(0)) FileName$ = Left$(FData.cFileName, nPos% - 1) Cells(nCount&, 1).Value = Root$ + "\" + FileName$ _ '>>>>>>>>>>>>>>>>>>>> '& gt;> ' If you don't want the path just use: ' Cells(nCount&,1).value = FileName$ End If StillOK& = FindNextFile(fHand&, FData) Loop Until StillOK = 0 fHand& = FindClose(fHand&) End Sub Public Sub GetFileList() Dim Path$ nCount& = 0 Path$ = InputBox("Enter the root for the file listing (e.g. 'c:\dir' orc:") If Len(Path$) = 0 Then Exit Sub GetDirectoryListing Path$ End Sub -

pasifize olan excel çalişma kitabinin aktifleştirilmes

ID : 1612
ISLEM : pasifize olan excel çalişma kitabinin aktifleştirilmes
MAKRO KODU : size iki ayrı seçenek öneriyorum örnek1: Sub Makro1() Range("A2").Select 10 ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate b = ActiveCell.Value satirno = ActiveCell.Row If b "" Then GoTo 10 End If Cells(satirno, 1) = Textbox1.Value End Sub örnek2: Sub Makro2() For a = 3 To 1000 b = Cells(a, 1).Value If b = "" Then Cells(a, 1) = Textbox1.Value GoTo 10 End If Next a 10 End Sub -

pasta diyagramı çizme

ID : 1613
ISLEM : pasta diyagramı çizme
MAKRO KODU : Sub kreisbogen() 'zeichnet Kreisbogen mit angegebenem Winkel Application.ScreenUpdating = False winkel = InputBox("Winkel ?") If winkel = Empty Or Not IsNumeric(winkel) Then Exit Sub ActiveSheet.Drawings.Add(100, 100, 100, 100, False) _ .Select For i = 0 To winkel k = 3.14159265358979 * i / 180 Selection.AddVertex 100 + 100 * Sin(k), 100 + 100 * Cos(k) i = i + 1 Next Selection.AddVertex 100, 100 Application.ScreenUpdating = True End Sub

pc kapatma kodları

ID : 1614
ISLEM : pc kapatma kodları
MAKRO KODU : Declare Function ExitWindowsEx& Lib "user32" _ (ByVal uFlags&, ByVal wReserved&) Global Const EWX_FORCE = 8 Global Const EWX_LOGOFF = 0 Global Const EWX_REBOOT = 2 Global Const EWX_SHUTDOWN = 1 Sub calistir() Dim Kapatma_Zamani As Variant Kapatma_Zamani = InputBox("Windows'un ne zaman kapanmasını istersiniz?", , _ Format(Now + TimeSerial(0, 1, 0), "hh:mm:ss")) If Kapatma_Zamani = "" Then Exit Sub Application.OnTime TimeValue(Kapatma_Zamani), "Windowsu_Kapat" End Sub Sub Windowsu_Kapat() Dim LResult LResult = ExitWindowsEx(EWX_SHUTDOWN, 0&) End Sub

pdf dosyası açma penceresi

ID : 1615
ISLEM : pdf dosyası açma penceresi
MAKRO KODU : Sub BrowsePDFDocument() Dim strDocument As String strDocument = Application.GetOpenFilename("PDF Files,*.pdf,All Files,*.*", 1, "Open File", , False) ' get pdf document name If Len(strDocument) -

pdf dosyası açma penceresi2

ID : 1616
ISLEM : pdf dosyası açma penceresi2
MAKRO KODU : Declare Function GetTempFileName Lib "kernel32" _ Alias "GetTempFileNameA" (ByVal lpszPath As String, _ ByVal lpPrefixString As String, ByVal wUnique As Long, _ ByVal lpTempFileName As String) As Long Declare Function FindExecutable Lib "shell32.dll" _ Alias "FindExecutableA" (ByVal lpFile As String, _ ByVal lpDirectory As String, ByVal lpResult As String) As Long Function GetExecutablePath(strFileType As String) As String Dim strFileName As String, f As Integer, strExecutable As String, r As Long If Len(strFileType) = 0 Then Exit Function ' no file type strFileName = String$(255, " ") strExecutable = String$(255, " ") GetTempFileName CurDir, "", 0&, strFileName ' get a temporary file name strFileName = Application.Trim(strFileName) strFileName = Left$(strFileName, Len(strFileName) - 3) & strFileType ' add the given file type f = FreeFile Open strFileName For Output As #f ' create the temporary file Close #f r = FindExecutable(strFileName, vbNullString, strExecutable) ' look for an associated executable Kill strFileName ' remove the temporary file If r > 32 Then ' associated executable found strExecutable = Left$(strExecutable, InStr(strExecutable, Chr(0)) - 1) Else ' no associated executable found strExecutable = vbNullString End If GetExecutablePath = strExecutable End Function Sub OpenPDFDocument() Dim strDocument As String, strExecutable As String strDocument = Application.GetOpenFilename("PDF Files,*.pdf,All Files,*.*", 1, "Open File", , False) ' get pdf document name If Len(strDocument) 0 Then Shell strExecutable & " " & strDocument, vbMaximizedFocus ' open pdf document End If End Sub -

pdf önizleme

ID : 1617
ISLEM : pdf önizleme
MAKRO KODU : Sub PrintingTest() Dim sFileName As String 'Change here to an appropriate file name sFileName = "C:\V080506.pdf" 'Prints three copies. PrintPDF2 sFileName, 3 MsgBox "Data has been sent. " & vbLf & _ "Please close the instance of Acrobat Reader after printing." End Sub -------------------------------------------------------------------------------- Sub PrintPDF2(ByVal FileName As String, Optional Copies As Long = 1) '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ '++ Prints the PDF files using a command line. '++ Written by Masaru Kaji aka Colo '++ Syntax '++ FileName : Required String expression that specifies a file name '++ - may include directory or folder, and drive.. '++ Copies : Optional Long. The number of copies to print. '++ If omitted one copy is printed. '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Const PrinterName As String = """Microsoft Office Document Image Writer""" Const DriverName As String = """Microsoft Office Document Image Writer""" Const PortName As String = """Microsoft Office Document Image Writer port:""" Dim cnt As Long Set myShell = CreateObject("WScript.Shell") For cnt = 1 To Copies myShell.Run ("AcroRd32.exe /t " & FileName & " " & PrinterName & " " & DriverName & " " & PortName) Next End Sub

pencereleri yerleştir penceresi

ID : 1618
ISLEM : pencereleri yerleştir penceresi
MAKRO KODU : Sub Dialog_06() Application.Dialogs(xlDialogArrangeAll).Show End Sub

pencerelerin hepsi minimize

ID : 1619
ISLEM : pencerelerin hepsi minimize
MAKRO KODU : Sub ButunPencerelerMinimize() Dim Pencere As Window For Each Pencere In Windows If Pencere.Visible = False Then Pencere.Visible = True Pencere.WindowState = xlMinimized Next End Sub

pencereyi dikey bölme

ID : 1620
ISLEM : pencereyi dikey bölme
MAKRO KODU : Sub GotoCol1() With Application ActiveWindow.FreezePanes = False Range("H1").Select ActiveWindow.FreezePanes = True .Goto Range("IV1") .Goto Range("Z1") End With End Sub

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