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


döngü

ID : 751
ISLEM : döngü
MAKRO KODU : C1, C2, C3 veC4'e X değerlerini 'D1, D2,D3 ve D4'e Y değerlerini 'E1, E2, E3 ve E4'e Z değerlerini girin. Sub xyz() Dim i As Integer Dim j As Integer Dim k As Integer Dim satir As Integer satir = 1 For k = 1 To 4 For j = 1 To 4 For i = 1 To 4 Cells(satir, 1) = Cells(k, 3) & Cells(j, 4) & Cells(i, 5) satir = satir + 1 Next i Next j Next k End Sub

döngü ile yanyana yazdırma

ID : 752
ISLEM : döngü ile yanyana yazdırma
MAKRO KODU : Sub TableauAnTrimestre() For An = 1 To 5 Cells(1, An + 1).Value = 2000 + An Next An For Trimestre = 1 To 4 Cells(Trimestre + 1, 1).Value = "Trim" & Trimestre Next Trimestre End Sub

döngülü formül girme

ID : 753
ISLEM : döngülü formül girme
MAKRO KODU : Sub JourSemaine() Dim semaine(1 To 7) As String semaine(1) = "Lundi" semaine(2) = "Mardi" semaine(3) = "Mercredi" semaine(4) = "Jeudi" semaine(5) = "Vendredi" semaine(6) = "Samedi" semaine(7) = "Dimanche" For i = 1 To 7 Selection.Offset(i - 1, 0).Formula = semaine(i) Next i End Sub

dtpicker le güncel tarih

ID : 754
ISLEM : dtpicker le güncel tarih
MAKRO KODU : a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, "dd" + a + "mm" + a + "yyyy")

dtpicker tarih değerini hücreye alma

ID : 755
ISLEM : dtpicker tarih değerini hücreye alma
MAKRO KODU : Private Sub DTPicker1_Change() [B3] = DTPicker1.Value End Sub

dtpickerin değerinin database den gelen bir değer olmasını istiyorsak

ID : 756
ISLEM : dtpickerin değerinin database den gelen bir değer olmasını istiyorsak
MAKRO KODU : Date = gunkontrol.Fields("tarih") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, "dd" + a + "mm" + a + "yyyy") ancak bu kod yazıldığında bilgisayarın sistem tarihi de database den galen tarih olarak değişiyor. bunu önlemek içi şöyle bir kontrol uygulayabiliriz: sondate = Date Date = gunkontrol.Fields("tarih") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, "dd" + a + "mm" + a + "yyyy") Date = sondate

durum çubuğunda bulunduğun adres

ID : 757
ISLEM : durum çubuğunda bulunduğun adres
MAKRO KODU : Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _ ByVal Target As Excel.Range) Application.StatusBar = Sh.Name & ":" & Target.Address End Sub

durum çubuğunda bulunduğun adres2

ID : 758
ISLEM : durum çubuğunda bulunduğun adres2
MAKRO KODU : Thisworkbook'a Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.StatusBar = Application.UserName & "-" & _ ThisWorkbook.Path & "-" & Sh.Name & ":" & Target.Address Application.Caption = ThisWorkbook.Path & "-" & Sh.Name ActiveWindow.Caption = Target.Address End Sub

durum çubuğunda sayı mesaj

ID : 759
ISLEM : durum çubuğunda sayı mesaj
MAKRO KODU : Declare Function GetAsyncKeyState Lib "User32" _ (ByVal vKey As Integer) As Integer 'GetAsyncKeyState est asynchrone - La touche est mémorisée Sub testToucheA() For y = 1 To 10000 Application.StatusBar = y Next If (GetAsyncKeyState(65) 0) Then MsgBox "Touche A frappée." End If End Sub -

durum çubuğunda toplam alma (fare ile seçileni toplar)

ID : 760
ISLEM : durum çubuğunda toplam alma (fare ile seçileni toplar)
MAKRO KODU : Sub tridoublon() Worksheets("Feuil1").Range("A1").Sort _ key1:=Worksheets("Feuil1").Range("A2"), _ Order1:=xlAscending, Header:=xlGuess Set MaCell = Worksheets("Feuil1").Range("A1") Do While Not IsEmpty(MaCell) Set MaCellSuite = MaCell.Offset(1, 0) If MaCellSuite.Value = MaCell.Value Then MaCell.EntireRow.Delete End If Set MaCell = MaCellSuite Loop End Sub

düzen seçenekleri penceresi

ID : 761
ISLEM : düzen seçenekleri penceresi
MAKRO KODU : Sub Dialog_47() Application.Dialogs(xlDialogOptionsEdit).Show End Sub

e1:e15 'i toplayıp a1'e yazar

ID : 762
ISLEM : e1:e15 'i toplayıp a1'e yazar
MAKRO KODU : Sub GetSum() [A1].Value = Application.Sum([E1:E15]) End Sub

e10 hücresine yazı yaz sağdan sola kayarak yazsın

ID : 763
ISLEM : e10 hücresine yazı yaz sağdan sola kayarak yazsın
MAKRO KODU : Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub Rotieren() Dim C As Range Dim i% Set C = Range("E10") For i = 1 To 2000 C = Right(C, Len(C.Value) - 1) + Left(C, 1) Sleep 200 Next i End Sub

e2 hücresinde formülü aşağı doğru çekerek çoğaltır

ID : 764
ISLEM : e2 hücresinde formülü aşağı doğru çekerek çoğaltır
MAKRO KODU : Sub Düğme1_Tıklat() x = Cells(65536, 3).End(xlUp).Row Range("E2").AutoFill Destination:=Range("E2:E" & x) Application.Calculate End Sub

eğer "p" sütununda "evet" yazanlar listede yer alsın

ID : 765
ISLEM : eğer "p" sütununda "evet" yazanlar listede yer alsın
MAKRO KODU : Private Sub CommandButton1_Click() For Each yes In Range("P:P") If yes = "evet" Then ListBox1.AddItem yes.Offset(0, -12) End If Next End Sub

eğer a1 1 ise sayfa ekle

ID : 766
ISLEM : eğer a1 1 ise sayfa ekle
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value = 1 Then Dim sayfa As Worksheet Dim önek As String Dim sonek As Integer Set Sayfam = Worksheets.Add önek = "Sayfam" SonEkim = 1 On Error Resume Next Sayfam.Name = önek & sonek If Err.Number 0 Then önek = sonek + 1 Sayfam.Name = önek & sonek End If End If End Sub -

eğer a1 hücresi 1 ise mesaj kutusu çalışsın ve excelpazarı yazsın

ID : 767
ISLEM : eğer a1 hücresi 1 ise mesaj kutusu çalışsın ve excelpazarı yazsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" Then If Target.Value = "1" Then MsgBox "ExcelPazarı" End If End Sub

eğer a1 hücresi sıfırdan büyükse macro çalışsın

ID : 768
ISLEM : eğer a1 hücresi sıfırdan büyükse macro çalışsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Range("A1") >= 1 Then MsgBox "Aşkından Selamlar" End Sub

eğer a1 hücresinde işlem yapılırsa a2 hücresine değiştirilme tarihi ve saatini yazar

ID : 769
ISLEM : eğer a1 hücresinde işlem yapılırsa a2 hücresine değiştirilme tarihi ve saatini yazar
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target = Cells(1, 1) Then Cells(2, 1) = Now End Sub 'alternatif ŞİMDİ() or Bugün or Time

eğer a1 hücresinin değeri a3 hücresindeki değerden düşükse macro çalışsın

ID : 770
ISLEM : eğer a1 hücresinin değeri a3 hücresindeki değerden düşükse macro çalışsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" Or Target.Address = "$A$3" Then If Range("A1").Value -

eğer aktif hücre değeri 1 den büyük ise aktif hücrenin altına boş satır ekler

ID : 771
ISLEM : eğer aktif hücre değeri 1 den büyük ise aktif hücrenin altına boş satır ekler
MAKRO KODU : Sub InserLSiRupture() Set x = ActiveCell Do Until IsEmpty(x) If x.Row > 1 Then If x.Offset(-1, 0).Value x.Value Then Rows(x.Row).Insert Shift:=xlDown End If End If Set x = x.Offset(1, 0) Loop End Sub -

eğer aktif hücre numerik ise ve 500 den büyükse kalın yapar

ID : 772
ISLEM : eğer aktif hücre numerik ise ve 500 den büyükse kalın yapar
MAKRO KODU : Sub Action() If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500 End If End Sub

eğer aktif hücrede değer varsa onu a17'ye yazar

ID : 773
ISLEM : eğer aktif hücrede değer varsa onu a17'ye yazar
MAKRO KODU : Sub SelCurRegCopy() Selection.CurrentRegion.Select Selection.Copy Range("A17").Select ' Substitute your range here ActiveSheet.Paste Application.CutCopyMode = False End Sub

eğer formülü 7 tane ve daha fazlası

ID : 774
ISLEM : eğer formülü 7 tane ve daha fazlası
MAKRO KODU : 12 adet eğer formülünü araya + işlecini koyarak 2 ye bölmektir. Formül B1 hücresine yazılmış ve A1 hücresindeki veriyi kontrol etmektedir. =EĞER(A1="OCAK";OCAK!A1;EĞER(A1="ŞUBAT";ŞUBAT!A1;EĞER(A1="MART";MART!A1;EĞER(A1="NİSAN";NİSAN!A1;EĞER(A1="MAYIS";MAYIS!A1;EĞER(A1="HAZİRAN";HAZİRAN!A1))))))+EĞER(A1="TEMMUZ";TEMMUZ!A1;EĞER(A1="AĞUSTOS";AĞUSTOS!A1;EĞER(A1="EYLÜL";EYLÜL!A1;EĞER(A1="EKİM";EKİM!A1;EĞER(A1="KASIM";KASIM!A1;EĞER(A1="ARALIK";ARALIK!A1))))))

eğer sayfa boş ise alt bilgiye tarihi ekler değilse ekleyer ve yazdırır

ID : 775
ISLEM : eğer sayfa boş ise alt bilgiye tarihi ekler değilse ekleyer ve yazdırır
MAKRO KODU : Sub Datum_in_Fusszeile() Dim SeitenNummer%, X% Dim Zaehler As Boolean Zaehler = True X = ExecuteExcel4Macro("get.document(50)") For SeitenNummer = 1 To X If Zaehler = True Then With ActiveSheet.PageSetup .RightFooter = "&D" .LeftFooter = "" End With End If If Zaehler = False Then With ActiveSheet.PageSetup .RightFooter = "" .LeftFooter = "&D" End With End If ActiveWindow.SelectedSheets.PrintOut _ From:=SeitenNummer, To:=SeitenNummer, Copies:=1 Zaehler = Not Zaehler Next SeitenNummer End Sub

eğer sütunda veriler varsa yukarıdan aşağıya doğru seçer

ID : 776
ISLEM : eğer sütunda veriler varsa yukarıdan aşağıya doğru seçer
MAKRO KODU : Sub SelectFirstToLastInColumn() Set TopCell = Cells(1, ActiveCell.Column) Set BottomCell = Cells(16384, ActiveCell.Column) If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown) If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp) If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select End Sub

eğer yanyana 2 hücrede değer varsa sağdan sola doğru seçer

ID : 777
ISLEM : eğer yanyana 2 hücrede değer varsa sağdan sola doğru seçer
MAKRO KODU : Sub SelectFirstToLastInRow() Set LeftCell = Cells(ActiveCell.Row, 1) Set RightCell = Cells(ActiveCell.Row, 256) If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight) If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select End Sub

eğerle hücreye formül girme ve koda çevirme

ID : 778
ISLEM : eğerle hücreye formül girme ve koda çevirme
MAKRO KODU : Sub ExcelEger() [B1] = "=IF(A1>=50,""Sınıf Geçer"",""Sınıfta Kalır"")" End Sub Sub VBAEger() If [A1] >= 50 Then [B1] = "Sınıf Geçer" Else [B1] = "Sınıfta Kalır" End If End Sub

ehatalıysa formülünün izahı

ID : 779
ISLEM : ehatalıysa formülünün izahı
MAKRO KODU : Bu tür hata mesajlarının hepsinde aynı yöntemi uygulamak mümkündür. Unutulmamalıdır ki, hata mesajı olan hücrede bir formül bulunmaktadır. 'Farzedelim ki hatalı hücrede aşağıdaki gibi bir formül olsun. =DÜŞEYARA(B1;C1:D11;2;0) 'Düşeyara ile aranılan veri bulunamadığında hücrede #YOK hata değeri olacaktır. Dolayısı ile bu da o hücrenin içerisinde bulunduğu bir toplama 'dizisini hatalı olarak gösterecektir. O halde bu hücreye ya boşluk değeri ya da sıfır değeri atayabiliriz. Ama unutmayınız sıfır değeri çarpma 'işleminde sorun çıkartabilir. O halde boşluk değeri atayalım. Yukarıdaki formülü aşağıdaki gibi değiştiriniz. =EĞER(EHATALIYSA(DÜŞEYARA(B1;C1:D11;2;0));"";DÜŞEYARA(B1;C1:D11;2;0)) 'Yaptığımız tek şey normal olarak bildiğimiz EĞER formülü ile birlikte EHATALIYSA formülünü kullanmaktır. Formülün anlaşılması için aşağıdaki 'açıklamayı inceleyiniz. =EĞER(HATALIYSA(formül);"";formül)) '"Eğer formül hatalı sonuç veriyorsa hücreyi boş bırak, değil ise formül sonucunu yazdır."

eklantilerin tamamının kontrolü

ID : 780
ISLEM : eklantilerin tamamının kontrolü
MAKRO KODU : Sub Eklenti() Dim i As Integer Dim Eklenti Cells(1, 1).Value = "Eklenti Adı" Cells(1, 2).Value = "Eklenti Yolu" Cells(1, 3).Value = "Eklenti Boyutu" Cells(1, 4).Value = "Eklentiyi Oluşturma Tarihi" Cells(1, 5).Value = "Dosya Tipi" Set Eklenti = CreateObject("Scripting.FileSystemObject") For i = 1 To Application.AddIns.Count Cells(i + 1, 1).Value = Application.AddIns(i).Name 'adı Cells(i + 1, 2).Value = Application.AddIns(i).Path 'Dosya Yolu Cells(i + 1, 3).Value = Int(Eklenti.GetFile(Application.AddIns(i).FullName).Size / 1024) & " Kb" Cells(i + 1, 4).Value = Eklenti.GetFile(Application.AddIns(i).FullName).DateCreated Cells(i + 1, 5).Value = Eklenti.GetFile(Application.AddIns(i).FullName).Type If Application.AddIns(i).Installed = False Then Cells(i + 1, 6).Value = "Aktif Değil" Else Cells(i + 1, 6).Value = "Aktif" End If Next i Columns("A:F").EntireColumn.AutoFit End Sub

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