Makro Kod Listesi

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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