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


ara bul makrosu

ID : 331
ISLEM : ara bul makrosu
MAKRO KODU : Private Sub CommandButton1_Click() Dim FirstMatch As String, strVal As String, MyMsg As String Dim MyData As Variant If Len(TextBox1) >= 1 Then Set MyData = Columns("C").Find(TextBox1) If Not MyData Is Nothing Then FirstMatch = MyData.Address Do strVal = strVal & MyData.Address(False, False) & vbCrLf Set MyData = Columns("C").FindNext(MyData) Loop While Not MyData Is Nothing And MyData.Address FirstMatch End If Else MsgBox "Aranılacak değeri girin..." Exit Sub End If If strVal = Empty Then strVal = "Bulunamadı...." MyMsg = "Aranılan değer " & TextBox1 & " nın bulunduğu hücreler:" _ & vbCrLf & String(35, "*") MsgBox MyMsg & vbCrLf & strVal Set MyData = Nothing End Sub -

ara bul renklendir

ID : 332
ISLEM : ara bul renklendir
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 Sub Check_Values_2() Dim CurCell As Range For Each CurCell In Range("A1:A10") If CurCell.Value = 10 Then CurCell.Value = 21 Next End Sub

ara-bul komutu

ID : 333
ISLEM : ara-bul komutu
MAKRO KODU : UserForma Bir TextBox1 ve CommandButton1 ekliyerek aşağıdaki kodları CommandButtonu clikliyerek açacağınız kod sayfasına yazın. Private Sub CommandButton1_Click() Dim i As Byte If Len(TextBox1) > 0 Then For i = 1 To Worksheets.Count Call Myxxrt(Worksheets(i).Name) Next End If End Sub Private Function Myxxrt(ShName As String) Dim MyRng As Range On Error Resume Next Set MyRng = Range(Sheets(ShName).Cells.Find(TextBox1, LookAt:=xlWhole).Address) MsgBox "Aranılan değer " & ShName & " sayfasında " & MyRng.Address(False, False) & " hücresinde bulundu !" Set MyRng = Nothing End Function

araç çubuğu ekleme

ID : 334
ISLEM : araç çubuğu ekleme
MAKRO KODU : Ancienne version Sub Creation_barre_outil() Application.ScreenUpdating = False Toolbars.Add Name:="Outils NewGam" Toolbars("Outils NewGam").Visible = True Set BarOutil = Toolbars("Outils NewGam").ToolbarButtons BarOutil.Add Button:=214, Before:=1, OnAction:="Action0",Enabled:=True,Pushed:=False BarOutil(1).Name = "Interface" Set BarOutil = Toolbars("Outils NewGam").ToolbarButtons BarOutil.Add Button:=211, Before:=1, OnAction:="Action1", Enabled:=True,Pushed:=False BarOutil(1).Name = "CréeTarifCatalogue" Set BarOutil = Toolbars("Outils NewGam").ToolbarButtons BarOutil.Add Button:=213, Before:=1, OnAction:="Action2", Enabled:=True, Pushed:=False BarOutil(1).Name = "CreeTarifExport" Set BarOutil = Nothing 'Positionnement de la barre d'outils With Toolbars("Outils NewGam") .Left = 620 .Top = 450 .Width = 120 End With End Sub Sub Action0() Range("a1").Formula = "Commande Action0" End Sub Sub Action1() Range("a2").Formula = "Commande Action1" End Sub Sub Action2() Range("a3").Formula = "Commande Action2" End Sub Sub SupprimeBarOutil() On Error Resume Next Toolbars("Outils NewGam").Delete End Sub

araç çubuğu oluşturma ve silme

ID : 335
ISLEM : araç çubuğu oluşturma ve silme
MAKRO KODU : Sub Auto_open() Eigene_Symbolleiste_erzeugen End Sub Sub Eigene_Symbolleiste_erzeugen() Toolbars.Add Name:="Eigene_Symbolleiste" Toolbars("Eigene_Symbolleiste").Visible = True With Application .ShowToolTips = True: .LargeButtons = False: .ColorButtons = True End With With Toolbars("Eigene_Symbolleiste") .ToolbarButtons.Add Button:=211, Before:=1 .ToolbarButtons(1).OnAction = "Dieser_Befehl_wird_bei_Klick_ausgeführt" .ToolbarButtons(1).Name = ("Dieser Text erscheint als Quickinfotext, wenn die Maus an das Symbol gehalten wird") .Position = xlTop .Left = -1 .Top = -1 End With End Sub Sub Dieser_Befehl_wird_bei_Klick_ausgeführt() MsgBox "Diese Meldungsbox ist der Befehl, der bei Klick auf das Symbol ausgeführt wird.", vbOKOnly + vbInformation, "Funktion dieses Symbols" End Sub Sub Eigene_Symbolleiste_löschen() Dim Sym As Toolbar Toolbars("Eigene_Symbolleiste").Delete For Each Sym In Toolbars If Sym.Visible = True Then Sym.Left = 1 Next Sym End Sub Sub Auto_close() Eigene_Symbolleiste_löschen End Sub

araç çubuklarına resetleme

ID : 336
ISLEM : araç çubuklarına resetleme
MAKRO KODU : Sub toolres() For Each tb In Application.Toolbars tb.Reset Next tb End Sub

araç çubuklarını açılır kutuya ekler, oradan seçersin

ID : 337
ISLEM : araç çubuklarını açılır kutuya ekler, oradan seçersin
MAKRO KODU : Private Sub Workbook_Open() Dim CmdB As CommandBar Dim Ctl As CommandBarControl, nCtlC As CommandBarComboBox For Each Ctl In Application.CommandBars("Worksheet Menu Bar") _ .Controls If Ctl.Type = msoControlComboBox And _ Ctl.Caption = "Symbolleistenauswahl" Then Ctl.Delete End If Next Ctl With Application.CommandBars("Worksheet Menu Bar") Set nCtlC = .Controls.Add(Type:=msoControlComboBox, _ Before:=.Controls.Count, Temporary:=True) End With With nCtlC .Caption = "Symbolleistenauswahl" .OnAction = "Me_007_Visible" For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal Then .AddItem CmdB.NameLocal End If Next CmdB .DropDownLines = 20 .Width = 150 .ListIndex = 1 End With End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_007_Delete End Sub Public Sub Me_007_Visible() Dim CmdB As CommandBar Dim CtlC As CommandBarComboBox Dim CmdBName As String 'Dim CmdBName$ Set CtlC = Application.CommandBars("Worksheet Menu Bar") _ .Controls("Symbolleistenauswahl") CmdBName = CtlC.List(CtlC.ListIndex) For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal And _ CmdB.NameLocal = CmdBName Then CmdB.Visible = True Exit Sub End If Next CmdB MsgBox "Die Symbolleiste '" & CmdBName & "' existiert" & _ " nicht!", _ vbInformation, "Code-Beispiel (Me_007)" End Sub Public Sub Me_007_Delete() On Error Resume Next Application.CommandBars("Worksheet Menu Bar") _ .Controls("Symbolleistenauswahl").Delete On Error GoTo 0 End Sub

araç çubuklarının hepsini kaldırma

ID : 338
ISLEM : araç çubuklarının hepsini kaldırma
MAKRO KODU : Sub toolbar_disable() For Each tb In Toolbars tb.Visible = False 'true geri getirir Next tb End Sub

araç çubuklarının özelleştirilmesi ve geri dönmesi

ID : 339
ISLEM : araç çubuklarının özelleştirilmesi ve geri dönmesi
MAKRO KODU : Sub auto_open() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = False Next i Application.ScreenUpdating = True End Sub Sub auto_close() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = 1 Next i Application.ScreenUpdating = True End Sub

araç çubuklarının özelleştirilmesi, dosya menüsü kalır

ID : 340
ISLEM : araç çubuklarının özelleştirilmesi, dosya menüsü kalır
MAKRO KODU : Private VisibleCmdBs As New Collection Private Sub Workbook_Open() Dim CmdB As CommandBar For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal And CmdB.Visible = True Then VisibleCmdBs.Add CmdB, CmdB.Name CmdB.Visible = False End If Next CmdB End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim CmdB As Object For Each CmdB In VisibleCmdBs CmdB.Visible = True Next CmdB Set VisibleCmdBs = Nothing End Sub

araçlar menusu gizleme

ID : 341
ISLEM : araçlar menusu gizleme
MAKRO KODU : Sub Auto_Open() Application.CommandBars.FindControl(ID:=30007).Enabled = False End Sub Sub Auto_Close() Application.CommandBars.FindControl(ID:=30007).Enabled = True End Sub

aralarinda boşluk olan satirlari bir başka sayfaya akta

ID : 342
ISLEM : aralarinda boşluk olan satirlari bir başka sayfaya akta
MAKRO KODU : Application.ScreenUpdating = False For i = 1 To Cells(65536, 1).End(xlUp).Row If Trim(Cells(i, 1)) "" And Trim(Cells(i, 1)) "m.cinsi" Then Range(i & ":" & i).EntireRow.Copy Sheets("sayfa2").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next i Application.ScreenUpdating = True edit : yukarıdaki örnekteki gibi aplication 'un screenupdate'i daha sonra kullanılmayacaksa, true yapmak mantıksızdır. iş bittiğinde zaten otomatik olarak true olur. sen neden yaptın derseniz, alışkanlık. -

aralarinda boşluk olan satirlari bir başka sayfaya aktar

ID : 343
ISLEM : aralarinda boşluk olan satirlari bir başka sayfaya aktar
MAKRO KODU : Application.ScreenUpdating = False For i = 1 To Cells(65536, 1).End(xlUp).Row If Trim(Cells(i, 1)) "" And Trim(Cells(i, 1)) "m.cinsi" Then Range(i & ":" & i).EntireRow.Copy Sheets("sayfa2").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next i Application.ScreenUpdating = True edit : yukarıdaki örnekteki gibi aplication 'un screenupdate'i daha sonra kullanılmayacaksa, true yapmak mantıksızdır. iş bittiğinde zaten otomatik olarak true olur. sen neden yaptın derseniz, alışkanlık. -

arama ve bulma

ID : 344
ISLEM : arama ve bulma
MAKRO KODU : Sub bul() On Error GoTo 10 aranan = InputBox("İçeriği girtiniz", "Arama Yap", " ") cells.Find(aranan).Select Exit Sub 10 MsgBox "Aranan veri bulunamadı." End Sub

aranan kelimeyi bulup o satırı temizleyen makro

ID : 345
ISLEM : aranan kelimeyi bulup o satırı temizleyen makro
MAKRO KODU : Sub sil() For i = 1 To Range("A65536").End(xlUp).Row If Cells(i, 1) = "Sunta" Then Rows(i).Delete End If Next End Sub

arananı bulur hücresini rapor eder

ID : 346
ISLEM : arananı bulur hücresini rapor eder
MAKRO KODU : Sub Bul_Adres() Find = InputBox("Aranan değer?", "pir") On Error GoTo yok bul = Cells.Find(Find).Address MsgBox bul, vbInformation, "Aradığınız kaydın bulunduğu hücre:" Exit Sub yok: MsgBox "Kayıt bulunamadı", vbCritical End Sub

arayıp bulma ve mesajla sıralı olarak listeleme

ID : 347
ISLEM : arayıp bulma ve mesajla sıralı olarak listeleme
MAKRO KODU : Sub FindItAll() Dim oSheet As Object Dim Firstcell As Range Dim NextCell As Range Dim WhatToFind As Variant WhatToFind = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2) If WhatToFind "" And Not WhatToFind = False Then For Each oSheet In ActiveWorkbook.Worksheets oSheet.Activate oSheet.[a1].Activate Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Firstcell Is Nothing Then Firstcell.Activate MsgBox ("Found " & Chr(34) & WhatToFind & Chr(34) & " in " & oSheet.Name & "!" & Firstcell.Address) On Error Resume Next While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address) Set NextCell = Cells.FindNext(After:=ActiveCell) If Not NextCell.Address = Firstcell.Address Then NextCell.Activate MsgBox ("Found " & Chr(34) & WhatToFind & Chr(34) & " in " & oSheet.Name & "!" & NextCell.Address) End If Wend End If Set NextCell = Nothing Set Firstcell = Nothing Next oSheet End If End Sub -

arkadaşlar textbox`a girdiğim yaziyi enter tuşuna basarak satirbaşi yapiyorum. ancak her enter`dan sonra görüyorum ki hücre içerisinde [] kare oluşmuş bu karelerin olmamasi için ne yapabilirim

ID : 348
ISLEM : arkadaşlar textbox`a girdiğim yaziyi enter tuşuna basarak satirbaşi yapiyorum. ancak her enter`dan sonra görüyorum ki hücre içerisinde [] kare oluşmuş bu karelerin olmamasi için ne yapabilirim
MAKRO KODU : Private Sub TextBox9_Change() [a1] = Replace(TextBox9, Chr(13), "") End Sub

arkaplan yanıp söner

ID : 349
ISLEM : arkaplan yanıp söner
MAKRO KODU : Sub FlashBack() 'Make cell range Background color, flash x times, x fast, in x color, 'when Ctrl-a is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range background flash! Set myCell = Range("A1:M8") Application.DisplayStatusBar = True Application.StatusBar = "... Select Cell to Stop and Edit or Wait for Flashing to Stop! " 'Make cell background flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 11 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.2 'Make cell flash, this many times! Do Until x = 2 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = xlNone Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub

artalan resmini değiştirmek sonra da none yapmak

ID : 350
ISLEM : artalan resmini değiştirmek sonra da none yapmak
MAKRO KODU : Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _ ByVal uAction As Long, _ ByVal uParam As Long, _ ByVal lpvParam As Any, _ ByVal fuWinIni As Long) As Long ' Const SPI_SETDESKWALLPAPER = 20 Const SPIF_UPDATEINIFILE = &H1 Const MyPic = "C:\muhtelif\resim1.bmp" ' Sub Test() SystemParametersInfo SPI_SETDESKWALLPAPER, ByVal 0&, MyPic, SPIF_UPDATEINIFILE End Sub 'none yapmak için .... Const SPI_SETDESKWALLPAPER = 20 Const SPIF_UPDATEINIFILE = &H1 Const MyPic = ""

aşağı yukarı kaydırma

ID : 351
ISLEM : aşağı yukarı kaydırma
MAKRO KODU : Sub myScrollDown() ActiveWindow.SmallScroll Down:=1 ActiveWindow.ActivateNext ActiveWindow.SmallScroll Down:=1 ActiveWindow.ActivatePrevious End Sub Sub myScrollUp() ActiveWindow.SmallScroll Up:=1 ActiveWindow.ActivateNext ActiveWindow.SmallScroll Up:=1 ActiveWindow.ActivatePrevious End Sub

aşağı, yukarı, sağ, sol

ID : 352
ISLEM : aşağı, yukarı, sağ, sol
MAKRO KODU : Sub Down() ActiveCell.Offset(1, 0).Select End Sub Sub up() ActiveCell.Offset(-1, 0).Select End Sub Sub Right() ActiveCell.Offset(0, 1).Select End Sub Sub Left() ActiveCell.Offset(0, -1).Select End Sub

aşağıdan yukarı doğru teker teker sildirme

ID : 353
ISLEM : aşağıdan yukarı doğru teker teker sildirme
MAKRO KODU : Sub Düğme1_Tıklat() e = Application.CountA(Range("A:A")) Cells(e, 1).Select Selection.Delete Shift:=xlUp End Sub

aşağidaki linkte yer alan panzehir isimli proseduru bir module yerleştirip, çaliştir.

ID : 354
ISLEM : aşağidaki linkte yer alan panzehir isimli proseduru bir module yerleştirip, çaliştir.
MAKRO KODU : Sub PanZehir() CommandBars("Cell").Reset End Sub

autofill

ID : 355
ISLEM : autofill
MAKRO KODU : Public Sub CopyDown() LastRow = Range("A65536").End(xlUp).Row For i = 1 To LastRow If Range("A" & i).Value = "" Then Range("A" & i - 1 & ":CB" & i - 1).Copy Destination:=Range("A" & i) End If Next i End Sub

ay adına göre sayfa açar ve aktif sayfayı kopyalar

ID : 356
ISLEM : ay adına göre sayfa açar ve aktif sayfayı kopyalar
MAKRO KODU : Sub Add_Sheet() Dim Sayfa As Worksheet Dim SayfaAdı As String SayfaAdı = Format(Now, "mmmm_yyyy") For Each Sayfa In Worksheets If Sayfa.Name = SayfaAdı Then MsgBox "Bu isimde bir sayfa bulunmaktadır." Exit Sub End If Next Sayfa Sheets.Add.Name = SayfaAdı Sheets(SayfaAdı).Move After:=Sheets(Sheets.Count) Sheets("Sayfa1").Range("A:IV").Copy _ Sheets(SayfaAdı).Range("A1") End Sub

ay adlarını sayfa isimleri oluşturarak yaz

ID : 357
ISLEM : ay adlarını sayfa isimleri oluşturarak yaz
MAKRO KODU : Sub NomFeuilMois() For I = 1 To 12 ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(30 * I, "mmmm") Next I End Sub

ayı otomatik tanıyan kodlar

ID : 358
ISLEM : ayı otomatik tanıyan kodlar
MAKRO KODU : Sub DoDays() Dim J As Integer Dim K As Integer Dim sDay As String Dim sTemp As String Dim iTarget As Integer Dim dBasis As Date iTarget = 13 While (iTarget 12) iTarget = Val(InputBox("Numeric month?")) If iTarget = 0 Then Exit Sub Wend Application.ScreenUpdating = False sTemp = Str(iTarget) & "/1/" & Year(Now()) dBasis = CDate(sTemp) For J = 1 To 31 sDay = Format((dBasis + J - 1), "dddd mm-dd-yyyy") If Month(dBasis + J - 1) = iTarget Then If J -

ayın olanın yanındaki hücreye kaydeder (a,b,c sütunundaki verilere göre)

ID : 359
ISLEM : ayın olanın yanındaki hücreye kaydeder (a,b,c sütunundaki verilere göre)
MAKRO KODU : Private Sub CommandButton1_Click() Cells([C65536].End(3).Row + 1, "C") = TextBox3 TextBox1 = "" TextBox2 = "" TextBox3 = "" UserForm_Initialize End Sub Private Sub UserForm_Initialize() SON = [C65536].End(3).Row + 1 TextBox1 = Cells(SON, "A") TextBox2 = Cells(SON, "B") TextBox3.SetFocus End Sub

ayın son gününü bulur aktif hücreye yazar

ID : 360
ISLEM : ayın son gününü bulur aktif hücreye yazar
MAKRO KODU : sub songun() Dim MyDate as Date ActiveCell.Value = DateSerial(Year(Now), Month(Now) + 1, 0) End Sub 'tarih şimdiki zaman hesaplama Sub ss1() 'As constants the following will not update [a1] = Int(Now) 'date [a2] = Now 'date and time [a3] = Date 'date [a4] = Date + Time 'same as now 'As Worksheet Functions the following will update [a5] = "=Today()" 'current date into worksheet formula [a6] = "=now()" 'current date [a7] = "=now() - Today()" 'current time when recalculated [a7].NumberFormat = "hh:mm" [a8] = "=MOD(NOW(),1)" 'current time when recalculated [a8].NumberFormat = "hh:mm" End Sub

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