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


sayfada büyük harf 2

ID : 1831
ISLEM : sayfada büyük harf 2
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$" & Target.Row Then kelime = Replace(Target.Value, "i", "İ") kelime = Replace(kelime, "ı", "I") Target.Value = StrConv(kelime, vbUpperCase) ElseIf Target.Address = "$C$" & Target.Row Then kelime = Replace(Target.Value, "i", "İ") kelime = Replace(kelime, "ı", "I") Target.Value = StrConv(kelime, vbUpperCase) ElseIf Target.Address = "$D$" & Target.Row Then kelime = Replace(Target.Value, "i", "İ") kelime = Replace(kelime, "ı", "I") Target.Value = StrConv(kelime, vbUpperCase) End If End Sub

sayfada çift tıklama ile saat ekleme

ID : 1832
ISLEM : sayfada çift tıklama ile saat ekleme
MAKRO KODU : Sub auto_open() Worksheets("Sayfa1").OnDoubleClick = "Mein_Makro" End Sub Sub Mein_Makro() ActiveCell.Value = Time End Sub

sayfada çift tıklama yasak

ID : 1833
ISLEM : sayfada çift tıklama yasak
MAKRO KODU : Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _ ByVal Target As Range, ByVal Cancel As Boolean) Cancel = True End Sub

sayfada enter ile bir üst hücreye

ID : 1834
ISLEM : sayfada enter ile bir üst hücreye
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlUp End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub

sayfada enter ile sağa doğru ilerleme

ID : 1835
ISLEM : sayfada enter ile sağa doğru ilerleme
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlToRight End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub

sayfada enter iptali

ID : 1836
ISLEM : sayfada enter iptali
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlToLeft End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub

sayfada formüller silinmesin (diğerlerinin silinmesine izin verir)

ID : 1837
ISLEM : sayfada formüller silinmesin (diğerlerinin silinmesine izin verir)
MAKRO KODU : Sayfanın kod bölümüne Option Explicit Private Sub Worksheet_Deactivate() Application.OnKey "{del}" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then Application.OnKey "{del}", "" Else Application.OnKey "{del}" End If End Sub 'Thisworbook a Option Explicit

sayfada formülleri silmeyi engelleme (delete tuş iptali)

ID : 1838
ISLEM : sayfada formülleri silmeyi engelleme (delete tuş iptali)
MAKRO KODU : sayfanın kod bölümüne Private Sub Worksheet_Deactivate() Application.OnKey "{del}" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then Application.OnKey "{del}", "" Else Application.OnKey "{del}" End If End Sub

sayfada formüllü hücreleri records sayfasına ayrıntılı kaydeder

ID : 1839
ISLEM : sayfada formüllü hücreleri records sayfasına ayrıntılı kaydeder
MAKRO KODU : Sub ListNames() On Error GoTo ErrHndlr Application.ScreenUpdating = False Set OutputRange = Selection RetSheet = ActiveSheet.Name NameCnt = ActiveWorkbook.Names.Count For Each Sheet In ActiveWorkbook.Sheets Sheet.Select Set FnRange = Cells.SpecialCells(xlFormulas) For i = 1 To NameCnt With FnRange Set c = .Find(ActiveWorkbook.Names(i).Name, LookIn:=xlFormulas) If Not c Is Nothing Then firstAddress = c.Address Do OutputRange.Offset(n, 0).Value = ActiveWorkbook.Names(i).Name OutputRange.Offset(n, 1).Value = ActiveSheet.Name OutputRange.Offset(n, 2).Value = c.Address(False, False) OutputRange.Offset(n, 3).Value = "'" & c.Formula OutputRange.Offset(n, 4).Value = c.Value n = n + 1 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address firstAddress End If End With Next i Next Sheet Sheets(RetSheet).Select Application.ScreenUpdating = True Exit Sub ErrHndlr: Set FnRange = Cells(1, 1) Resume Next End Sub Sub FindNakamedRangeReferences() Dim NameArray() As String Count = 0 Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Record").Delete Worksheets(1).Select Worksheets.Add.Name = "Record" With Worksheets("Record") .Range("a1").Value = "Worksheet Name" .Range("b1").Value = "Cell Address" .Range("c1").Value = "Formula" .Range("d1").Value = "Value" End With NamedRangeCount = ActiveWorkbook.Names.Count ReDim NameArray(NamedRangeCount) For i = 1 To NamedRangeCount NameArray(i) = ActiveWorkbook.Names.Item(i).Name Next i For j = 2 To ActiveWorkbook.Sheets.Count On Error Resume Next Worksheets(j).Activate Range("a1").Select Worksheets(j).Range("a1", Range("a1").SpecialCells(xlCellTypeLastCell)). _ SpecialCells(xlCellTypeFormulas).Select For Each myCell In Selection For i = 1 To NamedRangeCount If (InStr(myCell.Formula, NameArray(i)) 0) Then Worksheets("Record").Cells(2, 1).Offset(Count, 0).Value = Worksheets(j).Name Worksheets("Record").Cells(2, 1).Offset(Count, 1).Value = myCell.Address Worksheets("Record").Cells(2, 1).Offset(Count, 2).Value = "'" & myCell.Formula Worksheets("Record").Cells(2, 1).Offset(Count, 3).Value = myCell.Value Worksheets("Record").Cells(2, 1).Offset(Count, 4).Value = NameArray(i) Count = Count + 1 End If Next i Next myCell Next j Sheets("Record").Select End Sub -

sayfada internet explorer ile internet

ID : 1840
ISLEM : sayfada internet explorer ile internet
MAKRO KODU : Thisworkbooka Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate "http://www.excel-lex.de.vu" End Sub

sayfada kaç adet formül var sayar bulur

ID : 1841
ISLEM : sayfada kaç adet formül var sayar bulur
MAKRO KODU : Sub Countformula() Dim R As Integer R = 0 Range(Cells(1, 1), Selection.SpecialCells(xlLastCell)).Select For Each Cell In Selection If Left(Cell.Formula, 1) = "=" Then R = R + 1 End If Next Cell Selection.SpecialCells(xlFormulas, 23).Select MsgBox "toplam " & R & " adet formül bulundu. Sayfa " & ActiveSheet.Name & " de" End Sub Sub CountFormSub() MsgBox ActiveSheet.UsedRange.SpecialCells(xlFormulas).Count End Sub Function countformulas() As Integer Dim x As Range Dim y As Integer Application.Volatile For Each x In ActiveSheet.UsedRange If x.HasFormula Then y = y + 1 Next x countformulas = y End Function

sayfada kayan yazi

ID : 1842
ISLEM : sayfada kayan yazi
MAKRO KODU : SAYFADA KAYAN YAZI Sub KayanYazi() [J2] = "" For i = 1 To 10 On Error Resume Next For j = 1 To 1000000 j = j + 0 Next j Cells(1, i).Value = "kayan yazi" Cells(1, i - 1).Value = "" Next End Sub

sayfada koruma olup olmadığını öğrenme

ID : 1843
ISLEM : sayfada koruma olup olmadığını öğrenme
MAKRO KODU : Sub Blattschutz_Ja_Nein() If ActiveSheet.ProtectContents = True Then MsgBox "sayfa korumalı !", 64, "BLATTSCHUTZ" Exit Sub End If If ActiveSheet.ProtectContents = False Then MsgBox "Sayfada koruma yok !", 64, "BLATTSCHUTZ" Exit Sub End If End Sub

sayfada link silme

ID : 1844
ISLEM : sayfada link silme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) ActiveSheet.Hyperlinks.Delete End Sub

sayfada metin kutusu oluşturma

ID : 1845
ISLEM : sayfada metin kutusu oluşturma
MAKRO KODU : Sub Make_Textbox() r = 5 c = 5 w = Cells(1, 1).Resize(1, c).Width h = Cells(1, 1).Resize(r, 1).Height Worksheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, w, h, 200, 50).TextFrame.Characters.Text = "Test Box" End Sub

sayfada not verme

ID : 1846
ISLEM : sayfada not verme
MAKRO KODU : Sub Case_Kullan() Select Case ActiveCell.Value Case 0 To 44 ActiveCell.Offset(0, 1).Value = "Kaldı" Case 45 To 60 ActiveCell.Offset(0, 1).Value = "Orta" Case 61 To 80 ActiveCell.Offset(0, 1).Value = "İyi" Case 81 To 100 ActiveCell.Offset(0, 1).Value = "Pekiyi" End Select End Sub

sayfada numerik değer girilirse mesaj ver

ID : 1847
ISLEM : sayfada numerik değer girilirse mesaj ver
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If IsNumeric(Target) Then MsgBox "Dikkat?", vbQuestion + vbYesNo Else MsgBox "", vbQuestion + vbYesNo End If End Sub

sayfada rakamı bul veya yakınını bulma

ID : 1848
ISLEM : sayfada rakamı bul veya yakınını bulma
MAKRO KODU : Sub YakiniBul() Dim i As Integer Dim hucre As Range Range("A1:A1000").ClearFormats k = Abs(Range("c1") - Range("B1")) For i = 1 To WorksheetFunction.CountA(Range("B1:B1000")) deger = Abs(Range("c1") - Cells(i, 2)) If deger > k Then GoTo git Else k = deger End If git: Next i For Each hucre In Range("B1:B1000") If hucre.Value = k + Range("C1") Then hucre.Offset(0, -1).Font.ColorIndex = 3 ElseIf hucre.Value = Abs(k - Range("C1")) Then hucre.Offset(0, -1).Font.ColorIndex = 3 End If Next hucre End Sub

sayfada renklendirilmesini istediğiniz sayıyı msgboxa yazınız

ID : 1849
ISLEM : sayfada renklendirilmesini istediğiniz sayıyı msgboxa yazınız
MAKRO KODU : Option Explicit Option Compare Text Sub Check_Values_1() On Error Resume Next Dim CurCell As Range Dim Heading As String Dim Prompt As String Dim Criteria As Variant Dim Color As Long Dim lRows As Long Dim lCols As Long Dim lAllCells As Long lRows = ActiveSheet.Rows.Count lCols = ActiveSheet.Columns.Count lAllCells = lRows * lCols If Selection.Cells.Count = lAllCells Then MsgBox "To check the entire sheet, please select only one cell", 64 Exit Sub End If Heading = "Enter Criteria" Prompt = "Enter the value you want to find and highlight." Color = 3 Criteria = InputBox(Prompt, Heading) If Criteria = "" Then Exit Sub ElseIf IsNumeric(Criteria) Then Criteria = CLng(Criteria) ElseIf IsDate(Criteria) Then Criteria = CDate(Criteria) Else Criteria = CStr(Criteria) End If If Selection.Cells.Count > 1 Then For Each CurCell In Selection If CurCell.Value = Criteria Then CurCell.Interior.ColorIndex = Color Next CurCell Else For Each CurCell In ActiveSheet.UsedRange If CurCell.Value = Criteria Then CurCell.Interior.ColorIndex = Color Next CurCell End If End Sub

sayfada resim (image) silme

ID : 1850
ISLEM : sayfada resim (image) silme
MAKRO KODU : Sub Macro1() ActiveSheet.DrawingObjects.Delete End Sub

sayfada sabitlik

ID : 1851
ISLEM : sayfada sabitlik
MAKRO KODU : Menü aşağı-yukarı ve sağa-sola scrollunu kullanmanıza izin vermez. Basit bir kod, deneyince görürsünüz. Option Explicit Private Sub Workbook_Open() Sheets("Anasayfa").Select Sheets("Anasayfa").Range("a1:p40").ClearContents Sheets("Anasayfa").ScrollArea = "c5" End Sub

sayfada sadece formüllü hücreleri kilitler diğerleri açık kalır

ID : 1852
ISLEM : sayfada sadece formüllü hücreleri kilitler diğerleri açık kalır
MAKRO KODU : Sub formschutz() On Error GoTo fehlerbeh Application.ScreenUpdating = False ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _ Scenarios:=False With Cells .Locked = False .FormulaHidden = False End With With Cells.SpecialCells(xlFormulas, 23) .Locked = True .FormulaHidden = True End With ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True Exit Sub fehlerbeh: If Err.Number 0 Then MsgBox Err.Description End If Application.ScreenUpdating = True End Sub -

sayfada sağ fareye menü

ID : 1853
ISLEM : sayfada sağ fareye menü
MAKRO KODU : Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _ Cancel As Boolean) Dim icbc As Object For Each icbc In Application.CommandBars("cell").Controls If icbc.Tag = "brccm" Then icbc.Delete Next icbc If Not Application.Intersect(Target, Range("b1:b10")) _ Is Nothing Then With Application.CommandBars("cell").Controls _ .Add(Type:=msoControlButton, before:=6, _ temporary:=True) .Caption = "New Context Menu Item" .OnAction = "MyMacro" .Tag = "brccm" End With End If End Sub

sayfada sağ fareye menü ekleme

ID : 1854
ISLEM : sayfada sağ fareye menü ekleme
MAKRO KODU : Sub Auto_Open() With ShortcutMenus(xlWorksheetCell) .MenuItems.AddMenu "Menüpunkt1" With ShortcutMenus(xlWorksheetCell) _ .MenuItems("Menüpunkt1") .MenuItems.Add "Untermenüpunkt1_1", _ OnAction:="Makro1" .MenuItems.Add "Untermenüpunkt1_2", _ OnAction:="Makro2" .MenuItems.Add "Untermenüpunkt3", OnAction:="Makro3" End With .MenuItems.AddMenu "Menüpunkt2" With ShortcutMenus(xlWorksheetCell) _ .MenuItems("Menüpunkt2") .MenuItems.Add "Untermenüpunkt2_1", _ OnAction:="Makro3" .MenuItems.Add "Untermenüpunkt2_2", _ OnAction:="Makro4" End With End With End Sub Sub auto_close() Application.CommandBars("Cell").Reset End Sub

sayfada sağ klik geçersiz

ID : 1855
ISLEM : sayfada sağ klik geçersiz
MAKRO KODU : Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Cancel = True MsgBox "Sağ klik yasaklanmıştır! pir" End Sub

sayfada satır açar

ID : 1856
ISLEM : sayfada satır açar
MAKRO KODU : Sub satirac() Dim i As Long Dim gec, s, st As String Sheets("CIRO").Select For i = 1 To 3000 s = Cells(i, 1).Value If i > 2 Then gec = Cells(i - 1, 1).Value Else gec = s If s = "" Then GoTo son If i = 82 Then s = s End If If (s gec) And (gec "") Then st = Str(i) Rows(st).Select Selection.Insert Shift:=xlDown ActiveCell.Value = gec + "TOPLAM" Selection.Interior.ColorIndex = 40 Selection.Font.Bold = True i = i + 1 End If Next i son: End Sub -

sayfada tanımlanan adları silme

ID : 1857
ISLEM : sayfada tanımlanan adları silme
MAKRO KODU : Sub DeleteNames() Dim NameX As Name For Each NameX In Names ActiveWorkbook.Names(NameX.Name).Delete Next NameX End Sub

sayfada tanımlı adları siler

ID : 1858
ISLEM : sayfada tanımlı adları siler
MAKRO KODU : Sub DeleteAllNames() Dim Nm As Name For Each Nm In Names Nm.Delete Next End Sub

sayfada yazdığın her harfi büyük harfe çevirir

ID : 1859
ISLEM : sayfada yazdığın her harfi büyük harfe çevirir
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End Sub

sayfada, hücrede çift tıklamayla diğer sayfaya gitme

ID : 1860
ISLEM : sayfada, hücrede çift tıklamayla diğer sayfaya gitme
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sayfa = Target.Cells.Value Sheets("Sayfa3").Select End Sub

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