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


çıft satırlı mesaj kutusu 1

ID : 631
ISLEM : çıft satırlı mesaj kutusu 1
MAKRO KODU : MsgBox "Mesaj boxlarda satır başı yapamıyorum." & vbCrlf & "Bunun bir yolu olmalı !" & vbCrlf & "Acaba vbCrlf kullanırsam ne olur?", vbinformation

çıft satırlı mesaj kutusu 2

ID : 632
ISLEM : çıft satırlı mesaj kutusu 2
MAKRO KODU : Yada Alt+Enter'in Ascii kodu olan chr(10) kullanılabilir. Sub A() MsgBox "A" & Chr(10) & "B" & Chr(10) & "C" & Chr(10) & "D" & Chr(10) End Sub

çıft satırlı mesaj kutusu 3

ID : 633
ISLEM : çıft satırlı mesaj kutusu 3
MAKRO KODU : Sub msg() MsgBox "A" & Chr(13) & "B" & Chr(13) & "C" & Chr(13) & "D" & Chr(13) End Sub

çıft tıklamayla aktif sayfa harici sayfaları gizleyip gösterme

ID : 634
ISLEM : çıft tıklamayla aktif sayfa harici sayfaları gizleyip gösterme
MAKRO KODU : Option Explicit Sub AusEin() Dim S As Integer For S = 2 To Worksheets.Count Worksheets(S).Visible = Not Worksheets(S).Visible Next End Sub

çıft tıklamayla aktif sayfaya koruma koyma

ID : 635
ISLEM : çıft tıklamayla aktif sayfaya koruma koyma
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) ActiveSheet.Protect "abc" End Sub

çıft tıklamayla hücreye saat ve tarihli açıklama ekleme

ID : 636
ISLEM : çıft tıklamayla hücreye saat ve tarihli açıklama ekleme
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

çıft tıklamayla sayfa3'e git

ID : 637
ISLEM : çıft tıklamayla sayfa3'e git
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sayfa = Target.Cells.Value Sheets("sayfa3").Select End Sub

çıft tıklamayla tarih ve saat ekleme

ID : 638
ISLEM : çıft tıklamayla tarih ve saat ekleme
MAKRO KODU : Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) ActiveCell = Date & ", " & Time End Sub

çıft tıklayarak açıklamaya tarih-saat eklemek

ID : 639
ISLEM : çıft tıklayarak açıklamaya tarih-saat eklemek
MAKRO KODU : Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) ' MsgBox "destination: target.subaddress " & Target.SubAddress ' MsgBox "Source: Target.Range.Address " & Target.Range.Address ' MsgBox "Source: Target.Range.Value " & Target.Range(1, 1).Value Range(Target.SubAddress) = Target.ActiveCell End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'Get out of edit mode ActiveCell = Target.Text On Error Resume Next ActiveCell.AddComment On Error GoTo 0 ActiveCell.Comment.Visible = False ActiveCell.Comment.Text Text:="Value from: " & Target.Address(0, 0) _ & Chr(10) & Format(Now, "ddmmmyyyy hh:mm:ss") Cancel = True ' no further need to edit the cell End Sub

çıft_kayıtlari_arala

ID : 640
ISLEM : çıft_kayıtlari_arala
MAKRO KODU : Sub çift_kayıtlari_arala() totalrows = ActiveSheet.UsedRange.Rows.Count For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value Cells(Row - 1, 1).Value Then Rows(Row).Insert Next Row End Sub -

çıkış makrosu

ID : 641
ISLEM : çıkış makrosu
MAKRO KODU : kullanici = Application.UserName saat = Format(Now, "hh:mm:ss") tarih = Format(Date, "d mmmm yyyy dddd") sor = MsgBox(" GÖRÜŞMEK ÜZERE " & kullanici & Chr(10) & Chr(10) & _ "WWW.XXX.COM / +90 312 111 11 11" & Chr(10) & Chr(10) & _ "Tarih : " & tarih & Chr(10) & Chr(10) _ & "Saat : " & saat & Chr(10) & Chr(10) _ & "XXX A.Ş. İyi Çalışmalar Diler." & Chr(10) & Chr(10) & _ "dosyanın kaydedilmesini istiyormusunuz?", 4, "") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If End Sub

çıkış yordamı

ID : 642
ISLEM : çıkış yordamı
MAKRO KODU : Private Sub Command1_Click() pir = MsgBox("Çıkmak istediğinizden emin misiniz?", vbQuestion + vbYesNo, "Çıkış") Select Case pir Case vbYes End End Select End Sub

çift kayit engelleme (makrolu çözüm)

ID : 643
ISLEM : çift kayit engelleme (makrolu çözüm)
MAKRO KODU : Aşağıdaki kodu sayfanın kod sayfasına kopyalayarak deneyin. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [a:a]) Is Nothing Then Exit Sub say = WorksheetFunction.CountIf(Range("a1:a" & Target.Row - 1), Target) If say > 0 Then MsgBox "BU KAYIT MEVCUTTUR" Target.Select Target = "" End If End Sub

çift kayit engelleme.

ID : 644
ISLEM : çift kayit engelleme.
MAKRO KODU : Aşağıdaki kod sadece a sütunu için geçerli, buna birde e sütununu nasıl eklerim? Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [a:a]) Is Nothing Or Target = 0 Then Exit Sub UserForm1.Show End Sub Kodu aşağıdaki gibi düzenleyin. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 5 Then say = WorksheetFunction.CountIf([m:m], Target) If say > 0 Then Exit Sub UserForm1.Show End If End Sub

çift tıklama ile listboxtan silme

ID : 645
ISLEM : çift tıklama ile listboxtan silme
MAKRO KODU : Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If ListBox1.ListIndex = -1 Then Exit Sub cevap = MsgBox(ListBox1.List(, 0) & " nolu kaydı silmek istiyor musunuz?", vbYesNo) If cevap = vbYes Then Range(Cells(ListBox1.List(, 0) + 1, 2), Cells(ListBox1.List(, 0) + 1, 6)).Delete shift:=xlUp [a65536].End(3).Delete shift:=xlUp Call UserForm_Activate End If End Sub

çift tikladiğimda istediğim sayfaya gitsin

ID : 646
ISLEM : çift tikladiğimda istediğim sayfaya gitsin
MAKRO KODU : Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak.Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$C$18" Then Sheets("Sayfa2").Select End Sub

çift tikladiğimda istediğim sayfaya gitsin.

ID : 647
ISLEM : çift tikladiğimda istediğim sayfaya gitsin.
MAKRO KODU : Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak. Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$C$18" Then Sheets("Sayfa2").Select End Sub

çözünürlük bulma

ID : 648
ISLEM : çözünürlük bulma
MAKRO KODU : Declare Function GetClipCursor Lib "user32" (lprc As RECT) As Long Type RECT gauche As Long haut As Long droit As Long bas As Long End Type Dim oGCC As RECT Sub dimEcran() GetClipCursor oGCC With oGCC MsgBox .droit & " x " & .bas End With End Sub

çözünürlük bulma2

ID : 649
ISLEM : çözünürlük bulma2
MAKRO KODU : Declare Function GetSystemMetrics32 Lib "User32" _ Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long Sub DisplayMonitorInfo() Dim w As Long, h As Long w = GetSystemMetrics32(0) ' width in points h = GetSystemMetrics32(1) ' height in points MsgBox Format(w, "#,##0") & " x " & Format(h, "#,##0"), _ vbInformation, "Monitor Size (width x height)" End Sub

çözünürlük öğrenme

ID : 650
ISLEM : çözünürlük öğrenme
MAKRO KODU : Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Sub Bild() MsgBox ("Çözünürlük Pixel Değerleri: " & GetSystemMetrics(0) & " x " & GetSystemMetrics(1)) End Sub

d, e sütununda tek tıklamayla check atma

ID : 651
ISLEM : d, e sütununda tek tıklamayla check atma
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim iOffset As Integer On Error GoTo err_handler Application.EnableEvents = False If Not Application.Intersect(Target, Columns("D:E")) Is Nothing Then If Target.Column = 4 Then iOffset = 3 Else iOffset = 2 End If If IsEmpty(Target.Value) Then With Target .Font.Name = "Wingdings" .Value = Chr(252) End With Target.Offset(0, iOffset).Select Else Target.Value = "" Target.Offset(0, iOffset).Select End If End If err_handler: Application.EnableEvents = True End Sub

d2 hücresinde veri doğrulamalı açılır liste olsun açılır listenin otomatik genişlemesi daralması

ID : 652
ISLEM : d2 hücresinde veri doğrulamalı açılır liste olsun açılır listenin otomatik genişlemesi daralması
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Zelle = Target.Address Select Case Zelle Case "$D$2" Range("$D$2").ColumnWidth = 52 'entspricht 369 Pixel Case Else Range("$D$2").ColumnWidth = 16.43 'entspricht 120 Pixel End Select End Sub

daha önce koruma yaptiğim sayfanin koruma şifresini nasil kirabilirim

ID : 653
ISLEM : daha önce koruma yaptiğim sayfanin koruma şifresini nasil kirabilirim
MAKRO KODU : Excel içinde bir sayfaya şifre verdikten sonra bu şifreyi unuttuysanız aşağıdaki kodu uygulayıp bu sorunu çözebilirsiniz. Kod: Sub SifreAc() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For m = 65 To 66 For i1 = 65 To 66 For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 To 66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _ & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) _ & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _ & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next Next Next Next Next Next Next Next Next Next Next Next End Sub

dao ile 2 tarih arası

ID : 654
ISLEM : dao ile 2 tarih arası
MAKRO KODU : Dim dbs2 as Database Dim rst2 as Recordset Set dbs2 = OpenDatabase(datayolu) Set rst2 = dbs2.OpenRecordset("Select * from cr Where tarih>=datevalue('" & trh1.Value & "') and tarih -

data form açma

ID : 655
ISLEM : data form açma
MAKRO KODU : Sub data_form() ActiveWorkbook.Names.Add Name:="Database", RefersTo:="=" & Worksheets(1).Name & "!" & Range("A15:F35").Address Range("A1:F11").Select Worksheets(1).ShowDataForm End Sub

dataform açma

ID : 656
ISLEM : dataform açma
MAKRO KODU : Private Sub Workbook_Open() Sheets("Sayfa1").Select ActiveSheet.ShowDataForm End Sub

decimal kontrol

ID : 657
ISLEM : decimal kontrol
MAKRO KODU : Public Function DecControl(KeyAscii As Integer, Text As TextBox, ByVal NOOFDEC As Integer) As Integer If KeyAscii = 8 Then DecControl = KeyAscii Exit Function End If If NOOFDEC = 0 Then If InStr(1, "0123456789-", Chr(KeyAscii)) = 0 Then DecControl = 0 Exit Function Else DecControl = KeyAscii Exit Function End If Else If InStr(1, "0123456789.-", Chr(KeyAscii)) = 0 Then DecControl = 0 Exit Function End If End If If Len(Text) - Text.SelStart > NOOFDEC And Chr(KeyAscii) = "." Then DecControl = 0 Exit Function End If If KeyAscii 8 Then If InStr(1, Text, ".") 0 And Chr(KeyAscii) = "." Then DecControl = 0 Exit Function End If Dim pos As Integer Dim RET As Integer pos = InStr(1, Text.Text, ".") If pos = 0 Then If InStr(1, "0123456789.-", Chr(KeyAscii)) = 0 Then RET = 0 Else RET = KeyAscii End If Else 'IF AFTER DECIMAL If Text.SelStart + 1 > pos Then a = Len(Text.Text) - InStr(1, Text, ".") If a >= NOOFDEC Then RET = 0 Else RET = KeyAscii End If Else RET = KeyAscii End If End If Else RET = KeyAscii End If DecControl = RET End Function -

değere bağlı olarak diğer sütunu değiştir.

ID : 658
ISLEM : değere bağlı olarak diğer sütunu değiştir.
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i As Long For i = 1 To WorksheetFunction.CountA(Range("H:H")) If Cells(i, 8).Value = "A" And Left(Cells(i, 9), 3) "(-)" Then Cells(i, 9) = "(-)" & Cells(i, 9).Value Cells(i, 9).HorizontalAlignment = xlRight End If Next i End Sub -

değerlerin aynen kopyalama

ID : 659
ISLEM : değerlerin aynen kopyalama
MAKRO KODU : Sub aynideger() Dim Cel1 As Range, Cel2 As Range Set Cel1 = Range("A1:B1") Set Cel2 = Workbooks("Kitap1").Worksheets("Sayfa1").Range("D5") Cel1.Copy Cel2 End Sub

değişen hücreleri göster

ID : 660
ISLEM : değişen hücreleri göster
MAKRO KODU : aşağıda bu çalışmayı gerçekleştirecek kodu ekliyorum. Bu kodu bir module içerisine değil Alt+F11 ile VBAyı açın. Project Explorerden "This Workbook" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın. Normal module sayfasına eklerseniz çalışmaz. Deneme sonrası sonucu bildirirseniz memnun olurum. Sonuca farklı şekilde giden arkadaşlar kodlarını paylaşırsa sevinirim. Kod: Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger 0 Then yenideger = Range(adres).Value If deger yenideger Then Call yaz(deger, adres, yenideger) End If End If Range("IV1").Value = ActiveCell.Address Range("IV2").Value = ActiveCell.Value End Sub -

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