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


aktif sayfa ve hedef hücrelerde tarih formatı

ID : 271
ISLEM : aktif sayfa ve hedef hücrelerde tarih formatı
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim DateStr As String On Error GoTo EndMacro If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub End If If Target.Cells.Count > 1 Then Exit Sub End If If Target.Value = "" Then Exit Sub End If Application.EnableEvents = False With Target If .HasFormula = False Then Select Case Len(.Formula) Case 4 ' e.g., 9298 = 2-Sep-1998 DateStr = Left(.Formula, 1) & "/" & _ Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2) Case 5 ' e.g., 11298 = 12-Jan-1998 NOT 2-Nov-1998 DateStr = Left(.Formula, 1) & "/" & _ Mid(.Formula, 2, 2) & "/" & Right(.Formula, 2) Case 6 ' e.g., 090298 = 2-Sep-1998 DateStr = Left(.Formula, 2) & "/" & _ Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2) Case 7 ' e.g., 1231998 = 23-Jan-1998 NOT 3-Dec-1998 DateStr = Left(.Formula, 1) & "/" & _ Mid(.Formula, 2, 2) & "/" & Right(.Formula, 4) Case 8 ' e.g., 09021998 = 2-Sep-1998 DateStr = Left(.Formula, 2) & "/" & _ Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4) Case Else Err.Raise 0 End Select .Formula = DateValue(DateStr) End If End With Application.EnableEvents = True Exit Sub EndMacro: MsgBox "You did not enter a valid date." Application.EnableEvents = True End Sub

aktif sayfa ve hücreden itibaren tüm sayfaların isimlerini yazar ve sayfalara link ekler

ID : 272
ISLEM : aktif sayfa ve hücreden itibaren tüm sayfaların isimlerini yazar ve sayfalara link ekler
MAKRO KODU : Sub Tabellennamen_auflisten() 'Sisto Salera 24.06.2003 'Melanie Breden 25.06.2003 Dim i As Integer Dim myRange As Range Set myRange = ActiveCell myRange.Resize(Worksheets.Count).Select If (MsgBox("ACHTUNG: Der markierte Bereich wird überschrieben !" & vbCrLf & _ Chr(13) & " Trotzdem fortfahren ?", vbYesNo)) _ vbYes Then Exit Sub For i = 1 To Worksheets.Count With myRange.Cells(i) .Value = Worksheets(i).Name .Hyperlinks.Add _ Anchor:=myRange.Cells(i), _ Address:="", _ SubAddress:=.Value & "!" & .Address, _ ScreenTip:="Blatt (" & .Value & ")", _ TextToDisplay:=.Value End With Next i myRange.Select MsgBox ("Es befinden sich ") & ThisWorkbook.Worksheets.Count & _ (" Tabellenblätter in dieser Arbeitsmappe."), vbOKOnly, ThisWorkbook.Name End Sub -

aktif sayfada a1 0 ise b1 e olur b1 e ise resmi gösterir

ID : 273
ISLEM : aktif sayfada a1 0 ise b1 e olur b1 e ise resmi gösterir
MAKRO KODU : Option Explicit Private Sub Worksheet_Calculate() If Range("B1").Value = "E" Then ActiveSheet.Pictures(1).Visible = True Else ActiveSheet.Pictures(1).Visible = False End If End Sub 'Thisworkbook a Option Explicit

aktif sayfada a1 den itibaren alt alta 3 hücreyi kalın yapar

ID : 274
ISLEM : aktif sayfada a1 den itibaren alt alta 3 hücreyi kalın yapar
MAKRO KODU : Option Explicit Sub Top3LinesAllSheets() Dim wkSheet As Worksheet For Each wkSheet In Application.Worksheets With wkSheet.PageSetup .PrintTitleRows = "$1:$3" End With Sheets(wkSheet.Name).Rows("1:3").Font.Bold = True

aktif sayfada aynı verilerin kontrolü

ID : 275
ISLEM : aktif sayfada aynı verilerin kontrolü
MAKRO KODU : Veriler B,C,D,E sütununda Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' If Target.Column 6 Then Exit Sub ' burası aktif olursa yalnızca kontrolü f sütununa geçince yapar For x = 2 To [b65536].End(3).Row - 1 For y = x + 1 To [b65536].End(3).Row alan1 = Cells(x, 2) & Cells(x, 3) & Cells(x, 4) & Cells(x, 5) alan2 = Cells(y, 2) & Cells(y, 3) & Cells(y, 4) & Cells(y, 5) If alan1 = alan2 Then If MsgBox(y & ".satırdaki veri " & x & ".nci satırda girilmiş," & y & ".satırı silmek istiyor musunuz?", vbYesNo, "Uyarı") = vbYes Then Range(Cells(y, 2), Cells(y, 5)).Delete End If Next Next End Sub -

aktif sayfada belli hücrelere girilen sayıların başına çift sıfır ekler

ID : 276
ISLEM : aktif sayfada belli hücrelere girilen sayıların başına çift sıfır ekler
MAKRO KODU : Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim mahmut As Range, bayram As Range On Error GoTo pir: Set mahmut = Range("B3:C20,D1:D7") Application.EnableEvents = False For Each bayram In Range(Target.Address) If Not Intersect(bayram, mahmut) Is Nothing Then If bayram "" Then bayram = "'00" & bayram End If Next bayram Set mahmut = Nothing pir: Application.EnableEvents = True End Sub -

aktif sayfada comboboxta sayfa isimleri tıklayınca sayfaya gitme

ID : 277
ISLEM : aktif sayfada comboboxta sayfa isimleri tıklayınca sayfaya gitme
MAKRO KODU : Private Sub ComboBox1_Change() ActiveSheet.Cells(1, 1).Select If Not ComboBox1.Value = "" Then Worksheets(ComboBox1.Value).Select Sheets(1).ComboBox1.Value = "" End Sub

aktif sayfada çıktı aldıktan sonra mesaj alma

ID : 278
ISLEM : aktif sayfada çıktı aldıktan sonra mesaj alma
MAKRO KODU : Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Tabelle1" Then Application.OnTime Time + TimeSerial(0, 0, 1), "AfterPrint" End If End Sub ‘Modüle Public Sub AfterPrint() MsgBox ("Ich werde erst angezeigt, nachdem der Druck ''angestossen'' wurde !!!") ' hier auszuführenden Code ergänzen End Sub

aktif sayfada rakama göre renk

ID : 279
ISLEM : aktif sayfada rakama göre renk
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) Select Case Target.Value Case 1 Target.Interior.ColorIndex = 2 Case 2 Target.Interior.ColorIndex = 3 Case 3 Target.Interior.ColorIndex = 4 Case 4 Target.Interior.ColorIndex = 5 Case 5 Target.Interior.ColorIndex = 6 Case 6 Target.Interior.ColorIndex = 7 Case Else Target.Interior.ColorIndex = xlColorIndexNone End Select End Sub

aktif sayfada rakama göre zemin rengi verme

ID : 280
ISLEM : aktif sayfada rakama göre zemin rengi verme
MAKRO KODU : Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Set RaBereich = Range("B3:C20, D1:D7") ' Set RaBereich = Union(Range("C7:I26"), Range("L7:R26"), Range("U7:AA26"), Range("AD7:AJ26")) ' ActiveSheet.Unprotect ("Passwort") For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then With RaZelle Select Case UCase(.Value) Case "1" .Interior.ColorIndex = 1 .Font.ColorIndex = 2 '.NumberFormat = "General" ' Zellenformat Standard Case "2" .Interior.ColorIndex = 6 .Font.ColorIndex = 0 '.NumberFormat = "General" ' Zellenformat Standard Case "3" .Interior.ColorIndex = 3 .Font.ColorIndex = 2 '.NumberFormat = ";;;" Case "4" .Interior.ColorIndex = 4 .Font.ColorIndex = 0 '.NumberFormat = "General" ' Zellenformat Standard Case "KLAUS" .Interior.ColorIndex = 5 .Font.ColorIndex = 0 '.NumberFormat = "General" ' Zellenformat Standard Case Else .Interior.ColorIndex = xlNone .Font.ColorIndex = 0 '.NumberFormat = "General" ' Zellenformat Standard End Select End With End If Next RaZelle ' ActiveSheet.protect ("Passwort") Set RaBereich = Nothing End Sub

aktif sayfada rakama göre zemin rengi verme2

ID : 281
ISLEM : aktif sayfada rakama göre zemin rengi verme2
MAKRO KODU : Private Sub Worksheet_Calculate() Dim RaBereich As Range, RaZelle As Range Set RaBereich = Range("B3:C20, D1:D7") ' Set RaBereich = Union(Range("C7:I26"), Range("L7:R26"), Range("U7:AA26"), Range("AD7:AJ26")) ' ActiveSheet.Unprotect For Each RaZelle In RaBereich If Not Intersect(RaZelle, RaBereich) Is Nothing Then Select Case RaZelle.Value Case "1" RaZelle.Interior.ColorIndex = 1 Case "2" RaZelle.Interior.ColorIndex = 6 Case "3" RaZelle.Interior.ColorIndex = 3 Case "4" RaZelle.Interior.ColorIndex = 4 Case Else RaZelle.Interior.ColorIndex = xlNone End Select End If Next RaZelle ' ActiveSheet.protect Set RaBereich = Nothing End Sub

aktif sayfada rakamla kelime birleştirme

ID : 282
ISLEM : aktif sayfada rakamla kelime birleştirme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Dim Plage As Range Set Plage = Intersect(Target, Range("A1:A10")) If Plage Is Nothing Then Exit Sub For Each cellule In Plage If cellule.Value = 1 Then cellule.NumberFormat = "General"" er""" Else: cellule.NumberFormat = "General"" Sınıf""" End If Next End Sub

aktif sayfada sağ fare de menü

ID : 283
ISLEM : aktif sayfada sağ fare de menü
MAKRO KODU : Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True ' don't display the built-in popup menu DisplayCustomPopUp End Sub 'Modüle Option Explicit Const PopUpCommandBarName As String = "TemporaryPopupMenu" Sub DeletePopUp() On Error Resume Next CommandBars(PopUpCommandBarName).Delete On Error GoTo 0 End Sub Sub CreatePopUp() Dim cb As CommandBar, m As CommandBarPopup DeletePopUp Set cb = CommandBars.Add(PopUpCommandBarName, msoBarPopup, False, True) With cb With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 71 .Caption = "Custom Menu 1" .TooltipText = "Custom Tooltip Text 1" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 72 .Caption = "Custom Menu 2" .TooltipText = "Custom Tooltip Text 2" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 73 .Caption = "Custom Menu 3" .TooltipText = "Custom Tooltip Text 3" End With Set m = .Controls.Add(Type:=msoControlPopup) With m .BeginGroup = True .Caption = "Sub Menu" With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 71 .Caption = "Custom Menu 1" .TooltipText = "Custom Tooltip Text 1" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 72 .Caption = "Custom Menu 2" .TooltipText = "Custom Tooltip Text 2" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "MyMacroName" .FaceId = 73 .Caption = "Custom Menu 3" .TooltipText = "Custom Tooltip Text 3" End With End With Set m = Nothing End With Set cb = Nothing End Sub Sub DisplayCustomPopUp() On Error Resume Next Application.CommandBars(PopUpCommandBarName).ShowPopup On Error GoTo 0 End Sub Sub DisplayExampleUserForm() Load UserForm1 UserForm1.Show Unload UserForm1 End Sub Sub MyMacroName() Dim ctrl As CommandBarControl If Not UserForm1.Visible Then Set ctrl = Application.CommandBars.ActionControl ActiveCell.Formula = ctrl.Caption Set ctrl = Nothing Else If Application.International(xlCountrySetting) = 47 Then MsgBox "Dette kunne vært din egen makro som kjørte!", vbInformation, ThisWorkbook.Name Else MsgBox "This could be your macro running!", vbInformation, ThisWorkbook.Name End If End If End Sub

aktif sayfada sağ fare yasak

ID : 284
ISLEM : aktif sayfada sağ fare yasak
MAKRO KODU : Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True MsgBox "Click droit indisponible" End Sub

aktif sayfada tüm hücrelerde aynı hücreye devamlı rakam yaz, toplasın

ID : 285
ISLEM : aktif sayfada tüm hücrelerde aynı hücreye devamlı rakam yaz, toplasın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub On Error GoTo ErrorHandler Application.EnableEvents = False If IsNumeric(Target.Value) Then If Not Target.Comment Is Nothing Then Target = Target.Value + CDbl(Target.Comment.Text) Target.Comment.Delete End If Target.AddComment (Target.Text) Application.DisplayCommentIndicator = 0 End If ErrorHandler: Application.EnableEvents = True End Sub

aktif sayfada üst bilgi "my report" yazar "a1 den alır" (14 punto)

ID : 286
ISLEM : aktif sayfada üst bilgi "my report" yazar "a1 den alır" (14 punto)
MAKRO KODU : Sub Printr() ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _ & Sheets(1).Range("A1") ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub

aktif sayfada veri girilen hücrelere veri girildiği tarih ve saati açıklama olarak ekler

ID : 287
ISLEM : aktif sayfada veri girilen hücrelere veri girildiği tarih ve saati açıklama olarak ekler
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText "Die Zelle wurde am " & Format(Date, "dd.mm.yy") & " um " & Format(Now(), " hh:mm:ss") & " durch " & ActiveWorkbook.BuiltinDocumentProperties(7).Value & " geändert." End Sub 'Modül bölümüne Sub Kommentare_löschen() Application.DisplayCommentIndicator = xlCommentAndIndicator Cells.Select Selection.ClearComments Range("A1").Select Selection.ClearComments Application.CommandBars("Reviewing").Visible = False Application.DisplayCommentIndicator = xlCommentIndicatorOnly End Sub

aktif sayfada yazı yaz tarih ve saat,dakika,saniyesi ile açıklama ekler ve açıklamaları siler

ID : 288
ISLEM : aktif sayfada yazı yaz tarih ve saat,dakika,saniyesi ile açıklama ekler ve açıklamaları siler
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText "Die Zelle wurde am " & Format(Date, "dd.mm.yy") & " um " & Format(Now(), " hh:mm:ss") & " durch " & ActiveWorkbook.BuiltinDocumentProperties(7).Value & " geändert." End Sub Sub Kommentare_löschen() Application.DisplayCommentIndicator = xlCommentAndIndicator Cells.Select Selection.ClearComments Range("A1").Select Selection.ClearComments Application.CommandBars("Reviewing").Visible = False Application.DisplayCommentIndicator = xlCommentIndicatorOnly End Sub

aktif sayfada yazılan harfler büyük

ID : 289
ISLEM : aktif sayfada yazılan harfler büyük
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Target = UCase(Target) End Sub

aktif sayfada yazılan kelimeler büyük harf

ID : 290
ISLEM : aktif sayfada yazılan kelimeler büyük harf
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Target = BH(Target) End Sub Function BH(cevir) BH = Replace(cevir, "i", "İ") BH = Replace(BH, "ı", "I") BH = UCase(BH) End Function

aktif sayfadaki dikdörtgendeki yazıyı hücreye kopyalar

ID : 291
ISLEM : aktif sayfadaki dikdörtgendeki yazıyı hücreye kopyalar
MAKRO KODU : Dim MyData As DataObject Sub TestClip() Set MyData = New DataObject ActiveSheet.Shapes("Dikdörtgen 4").Select MyData.SetText Selection.Text MyData.PutInClipboard [A1].Select ActiveSheet.Paste End Sub

aktif sayfadaki formülleri bulur yeni sayfaya listeler

ID : 292
ISLEM : aktif sayfadaki formülleri bulur yeni sayfaya listeler
MAKRO KODU : Sub formullistele() Dim FormulaCells As Range, Cell As Range Dim FormulaSheet As Worksheet Dim Row As Integer ' Create a Range object for all formula cells On Error Resume Next Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23) ' Exit if no formulas are found If FormulaCells Is Nothing Then MsgBox "No Formulas." Exit Sub End If ' Add a new worksheet Application.ScreenUpdating = False Set FormulaSheet = ActiveWorkbook.Worksheets.Add FormulaSheet.Name = "Formulas in " & FormulaCells.Parent.Name ' Set up the column headings With FormulaSheet Range("A1") = "Address" Range("B1") = "Formula" Range("C1") = "Value" Range("A1:C1").Font.Bold = True End With ' Process each formula Row = 2 For Each Cell In FormulaCells Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%") With FormulaSheet Cells(Row, 1) = Cell.Address _ (RowAbsolute:=False, ColumnAbsolute:=False) Cells(Row, 2) = " " & Cell.Formula Cells(Row, 3) = Cell.Value Row = Row + 1 End With Next Cell ' Adjust column widths FormulaSheet.Columns("A:C").AutoFit Application.StatusBar = False End Sub

aktif sayfadan modüldeki makroyu çalıştırma

ID : 293
ISLEM : aktif sayfadan modüldeki makroyu çalıştırma
MAKRO KODU : Option Explicit Const hedefsahife = "Sayfa1" Sub auto_open() Worksheets(hedefsahife).OnDoubleClick = "pir" End Sub Sub auto_close() Worksheets(hedefsahife).OnDoubleClick = "" End Sub Sub pir() MsgBox "a ha da çalıştı" End Sub

aktif sayfanın adını aktif hücreye yazdırır

ID : 294
ISLEM : aktif sayfanın adını aktif hücreye yazdırır
MAKRO KODU : Sub sayfaismi() ActiveCell.Value = ActiveSheet.Name End Sub

aktif sayfanın aynısını kopyalar."newsheet" adında

ID : 295
ISLEM : aktif sayfanın aynısını kopyalar."newsheet" adında
MAKRO KODU : Sub Copy_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = "NewSheet" For Each wSht In Worksheets If wSht.Name = shtName Then MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again." Exit Sub End If Next wSht Sheets(1).Copy before:=Sheets(1) Sheets(1).Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) End Sub

aktif sayfanın ismi a1 hücresinde

ID : 296
ISLEM : aktif sayfanın ismi a1 hücresinde
MAKRO KODU : Sub A1nomfeuil() Application.ScreenUpdating = False For Each x In ActiveWorkbook.Sheets x.Activate [A1] = ActiveSheet.Name Next End Sub

aktif sayfanın ismi sayfa1 ise dosya kapanmasıın

ID : 297
ISLEM : aktif sayfanın ismi sayfa1 ise dosya kapanmasıın
MAKRO KODU : Private Sub Workbook_BeforeClose(Cancel As Boolean) If ActiveSheet.Name = "Liste2" Then Cancel = True End If End Sub 'Aktif sayfa ismi Sub ornek() MsgBox "Active Sheet : " & ActiveSheet.Name End Sub

aktif sayfanın ismini öğrenme

ID : 298
ISLEM : aktif sayfanın ismini öğrenme
MAKRO KODU : Sub TypeSheet() MsgBox "Bu sayfanın adı " & ActiveSheet.Name End Sub

aktif sayfanın kopyalanması

ID : 299
ISLEM : aktif sayfanın kopyalanması
MAKRO KODU : Sub Enregistre_1_Feuille() ActiveSheet.Copy Application.Dialogs(xlDialogSaveAs).Show 'Active la boite de dialogue Enregistrer sous End Sub

aktif sayfanın sağındaki ve solundaki sayfayı seçmek

ID : 300
ISLEM : aktif sayfanın sağındaki ve solundaki sayfayı seçmek
MAKRO KODU : Sub sol() Sheets(ActiveSheet.Index - 1).Select End Sub Sub sag() Sheets(ActiveSheet.Index + 1).Select End Sub

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