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


bul makrosu

ID : 481
ISLEM : bul makrosu
MAKRO KODU : Option Compare Binary Private Sub CheckBox4_Click() If CheckBox4.Value = True Then CheckBox3.Enabled = False End Sub Private Sub CommandButton1_Click() If TextBox1.Text = "" Then Exit Sub If CheckBox1.Value = True Then look = 1 Else look = 2 If CheckBox3.Value = True Then bas = 1 Else bas = 2 ListBox1.Clear Set c = Range("a:a").Find(TextBox1, LookIn:=xlValues, MatchCase:=CheckBox2.Value, LookAt:=look, SearchDirection:=bas) If Not c Is Nothing Then firstAddress = c.Address ListBox1.AddItem ListBox1.List(0, 0) = c.Address ListBox1.List(0, 1) = c basla: Set c = Range("a:a").FindNext(c) If Not c Is Nothing And c.Address firstAddress Then a = a + 1 ListBox1.AddItem ListBox1.List(a, 0) = c.Address ListBox1.List(a, 1) = c GoTo basla End If End If If CheckBox4.Value = 0 Then Exit Sub If ListBox1.ListCount > 0 Then For x = 0 To ListBox1.ListCount - 2 For y = x + 1 To ListBox1.ListCount - 1 If Val(Replace(ListBox1.List(x, 0), "$A$", "")) > Val(Replace(ListBox1.List(y, 0), "$A$", "")) Then Call swap(x, y) Next y, x End If End Sub Private Sub ListBox1_Click() Range(ListBox1.List(ListBox1.ListIndex, 0)).Select End Sub Sub swap(ind1, ind2) Set l = ListBox1 ara = l.List(ind1, 0) l.List(ind1, 0) = l.List(ind2, 0) l.List(ind2, 0) = ara ara = l.List(ind1, 1) l.List(ind1, 1) = l.List(ind2, 1) l.List(ind2, 1) = ara End Sub -

bul mesaj ver aynısı var diye

ID : 482
ISLEM : bul mesaj ver aynısı var diye
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Dim Bul As Range, Adres On Error GoTo HATA If Target.Column = 1 And Not Target = "" Then Set Bul = Range("A:A").Find(Target, LookAt:=xlWhole) Adres = Bul.Address Set Bul = Range("A:A").FindNext(Bul) If Not Bul.Address = Adres Then MsgBox Target & " değeri daha önce girilmiş" Target.Select End If End If HATA: End Sub

bul penceresi

ID : 483
ISLEM : bul penceresi
MAKRO KODU : Sub Dialog_32() Application.Dialogs(xlDialogFormulaFind).Show End Sub

bul penceresinin açılması

ID : 484
ISLEM : bul penceresinin açılması
MAKRO KODU : Private Sub CommandButton1_Click() Application.CommandBars.FindControl(ID:=1849).Execute End Sub

bul ve listele

ID : 485
ISLEM : bul ve listele
MAKRO KODU : Private Sub ComboBox1_Change() ListBox1.Clear son = Cells(65536, 1).End(xlUp).Row For i = 1 To son If Cells(i, 7).Value = ComboBox1.Value Then Cells(i, 1).Select c = c + 1 For y = 1 To 10 ListBox1.AddItem ListBox1.List(c - 1, y - 1) = Cells(i, y + 1).Value Next End If Next End Sub Private Sub ListBox1_Click() End Sub Private Sub UserForm_Initialize() ComboBox1.AddItem "İl Sosyal Hizmetler Müdürlüğü" ComboBox1.AddItem "Gözde Birsöz Çocuk Yuvası Müdürlüğü" ComboBox1.AddItem "75. Yıl Huzurevi Müdürlüğü" ComboBox1.AddItem "Aile Danışma Merkezi Müdürlüğü" ListBox1.ColumnCount = 10 End Sub

bul-değiştir-sil-kaydet makrosu

ID : 486
ISLEM : bul-değiştir-sil-kaydet makrosu
MAKRO KODU : Private Sub CommandButton1_Click() 'bul For Each hucre In Range("a2:a" & WorksheetFunction.CountA(Range("a1:a65000"))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next End Sub Private Sub CommandButton2_Click() 'değiştir ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value End Sub Private Sub CommandButton3_Click() 'sil satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range("A2:A65000")) For i = 1 To WorksheetFunction.CountA(Range("a2:a65000")) Cells(i + 1, 1) = i Next End Sub Private Sub CommandButton4_Click() 'kaydet Dim bak As Range Dim say As Integer For Each bak In Range("A1:A" & WorksheetFunction.CountA(Range("A1:A65000"))) If bak.Value = cbAd.Value Then MsgBox "Bu Kayıt numarası bulundu." Exit Sub End If Next bak For Each bak In Range("B1:B" & WorksheetFunction.CountA(Range("B1:B65000"))) If StrConv(bak.Value, vbUpperCase) = StrConv(cbAd.Value, vbUpperCase) Then MsgBox "Bu isimde bir kaydınız bulundu" Exit Sub End If Next bak b = WorksheetFunction.CountA(Sheets("sayfa1").Range("A:A")) Sheets("sayfa1").Range("a" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value End Sub Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range("A2:A6500")) ComboBox1.RowSource = "sayfa1!a2:a" & b End Sub

bullets (işaret) ekleme silme

ID : 487
ISLEM : bullets (işaret) ekleme silme
MAKRO KODU : Option Explicit Sub AddBullets() Dim Bullet As String Dim Dash As String Dim Cel As Range Dim Str As String Dim i As Long Bullet = "• " Dash = " - " 'select which cells to perform an action on For Each Cel In Selection Str = Cel.Value 'If there is already a bullet there then put a dash in its place If Left(Str, Len(Bullet)) = Bullet Then Str = Right(Str, Len(Str) - 2) Cel.Value = Dash & Str Else 'If there is already a dash there then trim back to normal text If Left(Str, Len(Dash)) = Dash Then Str = Trim(Cel.Value) i = Len(Str) - 1 If i >= 0 Then Cel.Value = Trim(Right(Str, i)) End If Else 'Otherwise add the bullet Cel.Value = Bullet & Str End If End If 'Go to the next cell in the selection and do the same thing Next Cel End Sub

bul-renklendir(hücre aralıklı)

ID : 488
ISLEM : bul-renklendir(hücre aralıklı)
MAKRO KODU : Sub Bul_Renklendir() Dim neyi As String, rng As Range, alan As Range neyi = Application.InputBox("A1:D20 hücrelerinde, bulmak istediğiniz veri", , "") Set alan = Range("A1:D20") alan.Interior.ColorIndex = xlNone For Each rng In alan If StrConv(rng, vbProperCase) = StrConv(neyi, vbProperCase) Then rng.Interior.ColorIndex = 35 End If Next rng Set alan = Nothing End Sub

bul-sil-değiştir-kaydet kodları

ID : 489
ISLEM : bul-sil-değiştir-kaydet kodları
MAKRO KODU : Private Sub CommandButton1_Click() For Each hucre In Range("a2:a" & WorksheetFunction.CountA(Range("a1:a65000"))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next End Sub Private Sub CommandButton2_Click() ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value End Sub Private Sub CommandButton3_Click() satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range("A2:A65000")) For i = 1 To WorksheetFunction.CountA(Range("a2:a65000")) Cells(i + 1, 1) = i Next End Sub Private Sub CommandButton4_Click() b = WorksheetFunction.CountA(Sheets("sayfa1").Range("A:A")) Sheets("sayfa1").Range("a" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value End Sub Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range("A2:A6500")) ComboBox1.RowSource = "sayfa1!a2:a" & b End Sub

bul-sil-değiştir-kaydet kodları2

ID : 490
ISLEM : bul-sil-değiştir-kaydet kodları2
MAKRO KODU : Dim comb() As New Class1 Dim index As Integer Private Sub ComboBox1_Click() index = ComboBox1.ListIndex + 1 End Sub Private Sub CommandButton1_Click() End End Sub Private Sub CommandButton2_Click() For a = 1 To 13 Controls("combobox" & a).RowSource = "" Cells(index, a) = Controls("combobox" & a) If IsNumeric(Controls("combobox" & a)) = True Then Cells(index, a) = Controls("combobox" & a) * 1 Next Call UserForm_Initialize End Sub Private Sub UserForm_Initialize() For a = 1 To 13 ReDim Preserve comb(13) Set comb(a).comb = Controls("combobox" & a) adres = Range(Cells(1, a), Cells(Cells(65536, 1).End(3).Row, a)).Address Controls("combobox" & a).RowSource = adres Next End Sub 'classmodüle Public WithEvents comb As MSForms.ComboBox Dim a As Integer Private Sub comb_Click() If a = 1 Then Exit Sub For a = 1 To 13 If UserForm1.Controls("combobox" & a).Name comb.Name Then UserForm1.Controls("combobox" & a).ListIndex = comb.ListIndex Next End Sub Private Sub comb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) a = 1 End Sub -

bulunduğun dizinde wav dosyası çalmak için

ID : 491
ISLEM : bulunduğun dizinde wav dosyası çalmak için
MAKRO KODU : Declare Function sndPlaySound Lib "winmm.dll" _ Alias "sndPlaySoundA" ( _ ByVal SoundName As String, _ ByVal Flags As Long) As Long Sub PlayWav(ByVal WavFileName As String) Call sndPlaySound(WavFileName, 0) End Sub Sub TestWav() Call PlayWav(ThisWorkbook.Path + "\pir.wav") End Sub

bulunulan hücrenin adresi (örnek g3)

ID : 492
ISLEM : bulunulan hücrenin adresi (örnek g3)
MAKRO KODU : Sub Markierung() Dim Mark_Bereich Mark_Bereich = Selection.Address(False, False) MsgBox Mark_Bereich End Sub

bulunulan klasöre tarihli yedek alır

ID : 493
ISLEM : bulunulan klasöre tarihli yedek alır
MAKRO KODU : Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim Phad As String Phad = ThisWorkbook.Path ActiveWorkbook.SaveCopyAs Filename:=Phad & "\" & Format(Now, "DD-MM-YY_hh-mm") & "_Backup_Beispielmappe_113.XLS" End Sub

buton ekle-kaldır

ID : 494
ISLEM : buton ekle-kaldır
MAKRO KODU : Sub EditionCopierOK() Application.CommandBars(1).Controls(2).Controls(4).Enabled = True End Sub Sub EditionCopierNo() Application.CommandBars("Edit").FindControl(ID:=19).Enabled = False End Sub Sub menuOutilsOptNo() Application.CommandBars("Tools").FindControl(ID:=522).Enabled = False End Sub Sub menuOutilsOptok() Application.CommandBars("Tools").FindControl(ID:=522).Enabled = True End Sub

buton ile diğer sayfayi yazdirmak

ID : 495
ISLEM : buton ile diğer sayfayi yazdirmak
MAKRO KODU : sheets("sayfa2").PrintOut Sn tb belki işinize yarar birde bunu deneyin a1 hüresine yazdığınız rakan kadar sayfa çıktısı alabilirsiniz Sub Test() Sheets("sayfa2").PrintOut From:=1, To:=[a1].Value End Su

buton komutlarina uyari ekleme

ID : 496
ISLEM : buton komutlarina uyari ekleme
MAKRO KODU : BU KOD BUTONLARDAN VERDİĞİNİZ KOMUTLARI YERİNE GETİRMEDEN ÖNCE KULLANICIYA UYARI VERİR Dim cevap cevap = MsgBox("Kaydı Silmek İstediğinize Eminmisiniz ? Evet Dersen Veri Kalıcı Olarak Silinecek ! ", vbYesNo + vbQuestion + vbDefaultcmdsil + vbApplicationModal, "Kayıt Silinecek") If cevap = vbNo Then End End If

buton resimleri

ID : 497
ISLEM : buton resimleri
MAKRO KODU : Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl Sub CommandBarControlID_List() Dim a, b, c Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = "test" Then ComBar.Delete Next Set ComBar = Application.CommandBars.Add(Name:="test", Position:=msoBarTop) b = 0 c = 1 For a = 1 To 50000 On Error Resume Next Set cbb = ComBar.Controls.Add(ID:=a) If Err.Number 0 Then GoTo weiter cbb.CopyFace With Workbooks("FaceIDs").Sheets(1) .Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a .Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate ActiveSheet.Paste .Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption End With If (c + 1) Mod 100 = 0 Then b = b + 3 c = c + 1 weiter: Application.CommandBars("test").FindControl(ID:=a).Delete Err.Clear Next End Sub Sub CommandBarFaceID_List() Dim a, b Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = "test" Then ComBar.Delete Next On Error Resume Next Set ComBar = Application.CommandBars.Add(Name:="test", Position:=msoBarTop) Set cbb = ComBar.Controls.Add(ID:=1) b = 0 For a = 1 To 3518 With cbb .FaceId = a .CopyFace End With With ThisWorkbook.Sheets(1) .Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a .Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate ActiveSheet.Paste End With If (a + 1) Mod 100 = 0 Then b = b + 2 Next End Sub Sub CommandBar_List() Application.ScreenUpdating = False Dim a, b, c, cbc, d b = 1 d = 0 For Each a In Application.CommandBars Cells(b + d, 1) = a.Name Cells(b + d, 2) = "Item-no: " & b For Each cbc In a.Controls d = d + 1 Cells(b + d, 3) = cbc.Caption Cells(b + d, 4) = Cells(cbc.Type, 10) Cells(b + d, 5) = "Type: " & cbc.Type Cells(b + d, 6) = "ID: " & cbc.ID Next b = b + 1 Next End Sub -

buton yardimiyla kayit olan satiri silme

ID : 498
ISLEM : buton yardimiyla kayit olan satiri silme
MAKRO KODU : Sheets("Liste").Rows(Cells(2, 1) & ":" & Cells(2, 1)).Delete Shift:=xlUp

butona hareket verir

ID : 499
ISLEM : butona hareket verir
MAKRO KODU : BU KOMUT BUTONU AŞŞAĞI YUKARI HAREKET ETTİRİR(ENTERE BASTIKÇA) Private Sub CommandButton1_Click() Sheets("sayfa2").Select Range("A1").Show End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) CommandButton1.Top = ActiveCell.Rows.Top End Sub

butona tıklayınca comboboxa veri aldırma

ID : 500
ISLEM : butona tıklayınca comboboxa veri aldırma
MAKRO KODU : Private Sub CommandButton1_Click() Dim NbreEnreg As Integer With UserForm1 .ComboBox1.RowSource = "A1:A9" NbreEnreg = .ComboBox1.ListCount .ComboBox1.ListRows = NbreEnreg .Show 'bu satırı silebilirsiniz End With End Sub

butonala text box açarak veri aktarimi

ID : 501
ISLEM : butonala text box açarak veri aktarimi
MAKRO KODU : Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range("b1").Text TextBox2.Text = Range("b2").Text TextBox3.Text = Range("b3").Text TextBox4.Text = Range("b4").Text TextBox5.Text = Range("b5").Text End Sub 2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak. Kod: Private Sub CommandButton1_Click() Range("b1").Select ActiveCell.Formula = TextBox1 Range("b2").Select ActiveCell.Formula = TextBox2 Range("b3").Select ActiveCell.Formula = TextBox3 Range("b4").Select ActiveCell.Formula = TextBox4 Range("b5").Select ActiveCell.Formula = TextBox5 End Sub

butonala text box açarak veri aktarimi.

ID : 502
ISLEM : butonala text box açarak veri aktarimi.
MAKRO KODU : Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range("b1").Text TextBox2.Text = Range("b2").Text TextBox3.Text = Range("b3").Text TextBox4.Text = Range("b4").Text TextBox5.Text = Range("b5").Text End Sub 2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak.Kod: Private Sub CommandButton1_Click() Range("b1").Select ActiveCell.Formula = TextBox1 Range("b2").Select ActiveCell.Formula = TextBox2 Range("b3").Select ActiveCell.Formula = TextBox3 Range("b4").Select ActiveCell.Formula = TextBox4 Range("b5").Select ActiveCell.Formula = TextBox5 End Sub

butonda veri kaydirma

ID : 503
ISLEM : butonda veri kaydirma
MAKRO KODU : EN BAŞA DÖN Private Sub CommandButton1_Click() TextBox1 = Cells(2, 1) ComboBox1 = Cells(2, 2) TextBox2 = Cells(2, 3) TextBox3 = Cells(2, 4) End Sub 'EN SONA GİT Private Sub CommandButton4_Click() Dim say As Integer say = WorksheetFunction.CountA(Range("A1:A65000")) TextBox1 = Cells(say, 1) ComboBox1 = Cells(say, 2) TextBox2 = Cells(say, 3) TextBox3 = Cells(say, 4) End Sub 'BİR,BİR GERİ GİT Private Sub CommandButton2_Click() If TextBox1 = 1 Then Exit Sub Else TextBox1 = TextBox1 - 1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If End Sub 'BİR,BİR İLERİ GİT Private Sub CommandButton3_Click() Dim say As Integer say = WorksheetFunction.CountA(Range("A1:A65000")) If TextBox1 = say Then Exit Sub Else TextBox1 = TextBox1 + 1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If End Sub

butonla sayfa koruması yapma

ID : 504
ISLEM : butonla sayfa koruması yapma
MAKRO KODU : Sub Set_Protection() On Error GoTo errorHandler Dim myDoc As Worksheet Dim cel As Range Set myDoc = ActiveSheet myDoc.Unprotect For Each cel In myDoc.UsedRange If Not cel.HasFormula And _ Not TypeName(cel.Value) = "Date" And _ Application.IsNumber(cel) Then cel.Locked = False cel.Font.ColorIndex = 5 Else cel.Locked = True cel.Font.ColorIndex = xlColorIndexAutomatic End If Next myDoc.Protect Exit Sub errorHandler: MsgBox Error End Sub

butonları ve numaralarını görün

ID : 505
ISLEM : butonları ve numaralarını görün
MAKRO KODU : Sub AfficheBoutons() Dim NewBarreOutil As CommandBar Dim NewBouton As CommandBarButton Dim i As Integer, IconOn As Integer, IconOff As Integer 'Supprime la barre si elle existe déjà On Error Resume Next Application.CommandBars("BarBouton").Delete On Error GoTo 0 Set NewBarreOutil = Application.CommandBars.Add _ (Name:="BarBouton", temporary:=True) NewBarreOutil.Visible = True IconOn = 1 IconOff = 200 For i = IconOn To IconOff Set NewBouton = NewBarreOutil.Controls.Add _ (Type:=msoControlButton, ID:=2950) NewBouton.FaceId = i NewBouton.Caption = "FaceID = " & i Next i NewBarreOutil.Width = 700 NewBarreOutil.Left = 50 NewBarreOutil.Top = 120 End Sub Sub SupMenuBar() Application.CommandBars("Worksheet Menu Bar").Enabled = False End Sub

butonların değerini labele yazdırma

ID : 506
ISLEM : butonların değerini labele yazdırma
MAKRO KODU : Private Sub UserForm_Activate() Do If UserForms.Count -

butonların gizlenmesi

ID : 507
ISLEM : butonların gizlenmesi
MAKRO KODU : Sub Düğme1_Tıklat() Dim a Dim x a = ActiveSheet.Shapes.Count For x = 1 To a ActiveSheet.Shapes(x).Visible = False Next End Sub

butonu kullanıma açma-kapama

ID : 508
ISLEM : butonu kullanıma açma-kapama
MAKRO KODU : Private Sub CommandButton1_Click() CommandButton3.Enabled = False CommandButton4.Enabled = False CommandButton5.Enabled = False End Sub Private Sub CommandButton2_Click() CommandButton3.Enabled = True CommandButton4.Enabled = True CommandButton5.Enabled = True End Sub

butonun adını söyler

ID : 509
ISLEM : butonun adını söyler
MAKRO KODU : Sub Shape_Index_Name() Dim myVar As Shapes Dim shp As Shape Set myVar = Sheets(1).Shapes For Each shp In myVar MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _ & shp.Name Next End Sub

button'lara fare ile geldiğimde renk değiştirmesi

ID : 510
ISLEM : button'lara fare ile geldiğimde renk değiştirmesi
MAKRO KODU : Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = vbYellow End Sub Private Sub UserForm_Initialize() CommandButton1.Tag = CommandButton1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = CommandButton1.Tag End Sub

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