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


a, b sütunlarını topla c'ye yaz

ID : 61
ISLEM : a, b sütunlarını topla c'ye yaz
MAKRO KODU : Sub abtoplaCyaz() Dim i As Integer On Error GoTo 10 For i = 1 To 50 If Cells(i, 1).Value Empty And Cells(i, 2).Value Empty And _ IsNumeric(Cells(i, 1).Value) And IsNumeric(Cells(i, 2).Value) Then Cells(i, 3).FormulaR1C1 = WorksheetFunction.Sum(Val(Cells(i, 1).Value) + Val(Cells(i, 2).Value)) Else 10 MsgBox "Geçersiz değer bulundu, lütfen kontrol ediniz ", vbExclamation, "H A T A !!! " Exit Sub End If Next i End Sub -

a,b,c sütununda arar bulur

ID : 62
ISLEM : a,b,c sütununda arar bulur
MAKRO KODU : Dim bul As String Private Sub CommandButton1_Click() On Error GoTo 10 bul = InputBox("LÜTFEN ARANACAK ŞUBE KODUNU YADA İSMİNİ GİRİNİZ!!!!!!") bassat = Range("A4:C65536").Find(bul).Row For a = bassat To 65536 sonsat = Range("A" & a, "C65536").Find(bul).Row Next a 10 If sonsat = 0 Then MsgBox ("ARADIĞINIZ VERİ BULUNAMADI") Exit Sub End If Range("A" & bassat, "C" & sonsat).Select End Sub

a,b,c,d sütunundaki verilerden h1 e yaz ı1 de bulsun

ID : 63
ISLEM : a,b,c,d sütunundaki verilerden h1 e yaz ı1 de bulsun
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Dim Bul As Range, ilkadres, i Application.ScreenUpdating = False If Target.Address = "$H$1" Then Sayfa1.[I1:I65536].ClearContents Set Bul = Sayfa1.[A:A].Find(Target, LookAt:=xlWhole) If Not Bul Is Nothing Then ilkadres = Bul.Address i = 1 Do i = i + 1 Target(i - 1, 2) = Bul(1, 4) Set Bul = Sayfa1.[A:A].FindNext(Bul) Loop Until ilkadres = Bul.Address End If End If End Sub

a:a sütunundaki dolu satirlarin altina boş satir ekler

ID : 64
ISLEM : a:a sütunundaki dolu satirlarin altina boş satir ekler
MAKRO KODU : AÇIKLAMA: A:A sütunundaki dolu satırların altına boş satır ekler Kod: Sub ZeileEinfuegen() Dim Zeile As Integer Zeile = 2 Application.ScreenUpdating = False Do Until Range("a" & Zeile).Value = "" Rows(Zeile & ":" & Zeile).Select Selection.Insert Shift:=xlDown Zeile = Zeile + 2 Loop Range("A1").Select Application.ScreenUpdating = True End Sub

a:a200 hücrelerindeki verilerden listbox a sadece dolu hücreleri alir. (boş hücreler gözükmez)

ID : 65
ISLEM : a:a200 hücrelerindeki verilerden listbox a sadece dolu hücreleri alir. (boş hücreler gözükmez)
MAKRO KODU : Private Sub UserForm_Initialize() Dim myrange As Range Dim myrange As Range Set myrange = Range("A1:A200") For Each c In myrange If c.Value = ListBox1.Value Then TextBox1.Value = ListBox1.Value & c.Value.Offset(1, 0).Value End If Next End Sub

a1 0 ise 10 ve 20.satırlar arasını gizle değilse göster

ID : 66
ISLEM : a1 0 ise 10 ve 20.satırlar arasını gizle değilse göster
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub

a1 0 ise a10:a20 arasını gizle değilse göster

ID : 67
ISLEM : a1 0 ise a10:a20 arasını gizle değilse göster
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub

a1 0 ise c10:c20 gizle 1 ise göster

ID : 68
ISLEM : a1 0 ise c10:c20 gizle 1 ise göster
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub

a1 1 ise b1 mart

ID : 69
ISLEM : a1 1 ise b1 mart
MAKRO KODU : sayfanın kod kısmına Private Sub Worksheet_Change(ByVal Target As Range) If Range("a1") = 1 Then Range("b1") = "Mart" End If End Sub

a1 10 karakterden fazla ise mesaj ver

ID : 70
ISLEM : a1 10 karakterden fazla ise mesaj ver
MAKRO KODU : Sub testNbCaractere() CellTest = Range("a1").Value If Len(CellTest) > 10 Then MsgBox "Pas plus de 10 caractères", vbOKOnly, "Erreur de caractères" Exit Sub End If End Sub

a1 b1 den itibaren numaralar(kodlar) ve damgalar

ID : 71
ISLEM : a1 b1 den itibaren numaralar(kodlar) ve damgalar
MAKRO KODU : Sub Zeichen_auslesen() Range("B1").Select ActiveCell.FormulaR1C1 = "=CHAR(ROW(RC))" Range("A1").Select ActiveCell.FormulaR1C1 = "=CODE(RC[1])" Range("A1:B1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With With Selection.Font .Name = "Arial" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Selection.Font.Bold = True Selection.AutoFill Destination:=Range("A1:B255"), Type:=xlFillDefault Range("A1").Select End Sub

a1 boş ise (silersen) 10 yapar

ID : 72
ISLEM : a1 boş ise (silersen) 10 yapar
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" And IsEmpty(Target) = True Then Target = "10" End Sub

a1 de adı yazan sayfayı acmak

ID : 73
ISLEM : a1 de adı yazan sayfayı acmak
MAKRO KODU : Sayfa1'de A1 hücresinde "Sayfa2" yazsın. Aşağıdaki kodu kullanın. Worksheets(Range("A1").Value).Select Eğer Value'yu eklemezseniz kod çalışmayabilir. Value yerine Text' de yazabilirsiniz. Eğer bu kodu başka sayfadan çalıştıracaksanız yani Sayfa1'de değilken çalıştıracaksanız aşağıdaki kodu kullanmalısınız. Worksheets(Worksheets("Sayfa1").Range("A1").Text).Select Böyle durumlarda genelde kodun kısa ve anlaşılabilir olması için sayfalara set atamasını yapmanızı tavsiye ederim. Sub SayfaAc() Set s1 = Worksheets("Sayfa1") Worksheets(s1.Range("A1").Text).Select End Sub

a1 de kritere göre filtreleme (süz işlemi)

ID : 74
ISLEM : a1 de kritere göre filtreleme (süz işlemi)
MAKRO KODU : Range("A1").AutoFilter Field:=1, Criteria1:=">2", Operator:=xlAnd, Criteria2:=" -

a1 de şartlı sayı verme

ID : 75
ISLEM : a1 de şartlı sayı verme
MAKRO KODU : Sub SelonCas() Nombre = ActiveCell.Value Select Case Nombre Case 1 To 5 Range("A1").Value = 0 Case 6, 7, 8, 9, 10 Range("A1").Value = 1 Case Else Range("A1").Value = 1000 End Select End Sub

a1 deki email adresine mesaj gönderir

ID : 76
ISLEM : a1 deki email adresine mesaj gönderir
MAKRO KODU : Sub Excel_Serienmail_via_Outlook_Senden() Dim OutApp As Object, Mail As Object Dim i As Integer Dim Nachricht For i = 1 To 10 'Variablen müssen bei jeder Schleife neu initalisiert werden Set OutApp = CreateObject("Outlook.Application") Set Nachricht = OutApp.CreateItem(0) With Nachricht .To = Cells(i, 1)'Adresse .Subject = Cells(i, 2) 'Betreffzeile .Body = Cells(i, 3) 'Sendetext 'Hier wird die Mail gleich in den Postausgang gelegt 'und die Sicherheitsabfrage muss jedesmall bestätigt werden '.Send 'Hier wird die Mail "angezeigt" 'aber gleich versendet,... OHNE Sicherheitsabrage .Display SendKeys "%s",True End With 'Variablen zurücksetzen sonst geht es nicht Set OutApp = Nothing 'CreateObject("Outlook.Application") Set Nachricht = Nothing 'OutApp.CreateItem(0) Application.Wait (Now + TimeValue("0:00:05")) Next i End Sub

a1 deki formülü öğrenme

ID : 77
ISLEM : a1 deki formülü öğrenme
MAKRO KODU : ‘=A1 yaz A1 deki formülü yazsın Function formul_al(hucre) If Left(hucre.Formula, 1) = "=" Then _ formul_al = Right(hucre.Formula, Len(hucre.Formula) - 1) Else _ formul_al = "" End Function

a1 deki isimle farklı kaydet

ID : 78
ISLEM : a1 deki isimle farklı kaydet
MAKRO KODU : Sub Speichern() test = Application.GetSaveAsFilename([a1]) If test = False Then Exit Sub ActiveWorkbook.SaveAs test End Sub

a1 deki isimle yeni sayfa + aynısı var ikazı

ID : 79
ISLEM : a1 deki isimle yeni sayfa + aynısı var ikazı
MAKRO KODU : Sub Test2() If Not Sheets("Sayfa1").Range("A1") = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = Sheets("Sayfa1").Range("A1") Then MsgBox "Bu isimli bir sayfa mevcut..... !" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") End If Set NewSh = Nothing End Sub

a1 deki isimle yeni sayfa oluşturma

ID : 80
ISLEM : a1 deki isimle yeni sayfa oluşturma
MAKRO KODU : Sub Test() Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") Set NewSh = Nothing End Sub

a1 deki isimleri listboxta sıralı olarak gösterir

ID : 81
ISLEM : a1 deki isimleri listboxta sıralı olarak gösterir
MAKRO KODU : Sub List_Alphab() Dim i As Integer, j As Integer Dim Entree As String Dim Cel As Range Set Cel = Range("A1") 'Pour chaque enregistrement For i = 0 To Cel.End(xlDown).Row - 1 'Récupère la valeur Entree = Cel.Offset(i) With UserForm1 'Pour chaque valeur de la listBox For j = 0 To .ListBox1.ListCount - 1 'Si la valeur de la listbox est > à la valeur à entrer 'on récupère l'index j et on sort de la boucle If .ListBox1.List(j) > Entree Then Exit For End If Next j 'ajout de la valeur à son emplacement spécifié par l'index j .ListBox1.AddItem Entree, j End With Next i UserForm1.Show End Sub

a1 deki kelimeyi sesli ve sessiz olarak ayırır

ID : 82
ISLEM : a1 deki kelimeyi sesli ve sessiz olarak ayırır
MAKRO KODU : Sub Cons_Voy() Dim i As Integer Dim Chaine As String Dim Caract As String * 1 Dim Conson As String, Voyel As String Chaine = Range("A1") For i = 1 To Len(Chaine) Caract = Mid(Chaine, i, 1) Select Case LCase(Caract) Case "a", "e", "i", "o", "u", "y" Voyel = Voyel & Caract Case Else Conson = Conson + Caract End Select Next i Range("A2") = Conson Range("A3") = Voyel End Sub

a1 den itibaren ne kadar sayfa varsa yazar

ID : 83
ISLEM : a1 den itibaren ne kadar sayfa varsa yazar
MAKRO KODU : Sub Blattname() i = 1 For Each Blatt In Sheets Range("A" & i) = Blatt.Name i = i + 1 Next End Sub

a1 den itibaren veri olan hücreye kadar seçer

ID : 84
ISLEM : a1 den itibaren veri olan hücreye kadar seçer
MAKRO KODU : Sub SelectActiveArea() Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select End Sub

a1 den itibaren verili hücrelere 1 er satır ekler

ID : 85
ISLEM : a1 den itibaren verili hücrelere 1 er satır ekler
MAKRO KODU : Sub ValMaxi() Dim i As Integer i = 1 Do While Range("A1").Offset(i) "" Rows(i + 1).Insert i = i + 2 Loop End Sub -

a1 den sayfa oluşturma

ID : 86
ISLEM : a1 den sayfa oluşturma
MAKRO KODU : Sub Test2() If Not Sheets("Sayfa1").Range("A1") = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = Sheets("Sayfa1").Range("A1") Then MsgBox "Bu isimli bir sayfa mevcut..... !" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") End If Set NewSh = Nothing End Sub

a1 den sıra numarası verir veya aktif satır numarasını versin(klavye-fare seç)

ID : 87
ISLEM : a1 den sıra numarası verir veya aktif satır numarasını versin(klavye-fare seç)
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) rowoffset = 0 Intersect(ActiveCell.EntireRow, Columns("A")).Value = ActiveCell.Row + rowoffset End Sub

a1 devamlı a2 de toplanacak

ID : 88
ISLEM : a1 devamlı a2 de toplanacak
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Static kod If Target.Address = "$A$1" Then Range("A2").Value = kod + Target End If kod = Target.Value End Sub

a1 e değer girin ce makro kodları çalıştırma

ID : 89
ISLEM : a1 e değer girin ce makro kodları çalıştırma
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range("a1")) Is Nothing Then "MAKROCODE" End If End Sub

a1 e değer girince 10 ile çarp a2 ye yaz

ID : 90
ISLEM : a1 e değer girince 10 ile çarp a2 ye yaz
MAKRO KODU : Sub RecupValeur() Dim Val1 'Dim Resultat As Integer (pour un résultat en entier) Val1 = Sheets("Feuil1").[a1].Value Resultat = Val1 * 10 Sheets("Feuil1").[a2].Value = (Resultat) MsgBox "Opération effectuée." & Chr(13) & Chr(13) _ & "Résultat :" & CStr(Resultat) End Sub

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