Makro Kod Listesi

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

ID : 1021
ISLEM : hücre biçimini ayarlamak
MAKRO KODU : Sorunuz üzerine biraz düşündüm. Aşağıdaki gibi kodlar sanırım isteğinizi karşılar. Aşağıda iki textbox için kod yazılmıştır. Textbox1 "A1" hücresine değer atıyor. Textbox2 ise "A1" hücresindeki değerin biçimini değiştiriyor. Textbox2'ye en az üç basamaklı bir biçim girin örneğin "O/E" şeklinde, daha az basamaklı değer için iki nolu koddaki mid formüllerini biçim uzunluğu kadar azaltın (OE için iki,O için bir mid kalsın). İkinci kodun yazılan biçim uzunluğunu dikkate alacak şekilde dahada geliştirilmesi mümkün. selamlar Kod: Private Sub TextBox1_Change() [a1] = TextBox1.Value End Sub Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) [a1].NumberFormat = "General \" & Mid(TextBox2.Value, 1, 1) & "\" & Mid(TextBox2.Value, 2, 1) & "\" & Mid(TextBox2.Value, 3, 1) End Sub

ID : 1022
ISLEM : hücre biçimlendir penceresi
MAKRO KODU : Sub Dialog_02() Application.Dialogs(xlDialogActiveCellFont).Show End Sub Sub Dialog_22() Application.Dialogs(xlDialogDeleteFormat).Show End Sub

ID : 1023
ISLEM : hücre biçimlendir/yazı tipleri penceresi
MAKRO KODU : Sub Dialog_30() Application.Dialogs(xlDialogFontProperties).Show End Sub

ID : 1024
ISLEM : hücre boş iken makro 1 dolu iken makro2
MAKRO KODU : Sayfanın kod kısmına Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("B3").Value = "" Then Call Makro1 Else Call Makro2 End If End Sub Sub Makro1() MsgBox "Selam" End Sub Sub Makro2() MsgBox "Günaydın" End Sub

ID : 1025
ISLEM : hücre değer değişince makro çalışsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" <> Empty Then Deneme End Sub Sub Deneme() MsgBox "suzunkopru" End Sub

ID : 1026
ISLEM : hücre değerine göre renk değiştirir
MAKRO KODU : BU KOD HÜCRELERİN DEĞERLERİNE GÖRE HÜCRE RENGİNİ DEĞİŞTİRİR Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target Case "65/4G": Target.Interior.ColorIndex = 15 ' gri Case "70/3G": Target.Interior.ColorIndex = 5 ' kırmızı Case Else: Target.Interior.ColorIndex = xlNone End Select End Sub

ID : 1027
ISLEM : hücre değerini açiklamaya ekleme
MAKRO KODU : İstediğin şeyi doğru anladıysam yaptım ve bende çalıştı. Ã imdi A1 den A20 ye kadar her hücrede ayrı bilgilerin var ve bunları günlük değiştiriyorsun.Vede her hücrede ayrı ayrı açıklaman olmasını ve bu hücrelerin günlük değişimlerini kaydetsin istiyorsun. Macroyu yazarken A1:A20 arasını baz aldım ve C1 hücresinede =bugün() fonksiyonunu yazarak o günün tarihini yazdırdım. Private Sub Worksheet_Change(ByVal Target As Range) Dim eski As String If Not Intersect(Target, Range("A1:A20")) Is Nothing Then yeni = Target.Value eski = Target.Comment.Text tarih = Range("c1").Value 'burdaki C1 o günün tarihinin yazdigi hücre. Target.Comment.Text Text:=eski & tarih & " / " & yeni & Chr(10) End If End Sub Bastaki if sadece A1 ve A20 arası hücrelere bilgi girdiğin zaman açıklamaya bilgi yazması için.Range("A1:A20") değiştirerek bu aralığı ayarlayabilirsin. Tek şart daha önceden elle A1 A20 arasına içi boş olan bir açıklama eklemen.(Ama içi boş olsun.Başlığı dahi olmasın) A1 ile A20 arasındaki herhangi bir hücrede değişiklik yaptığın an, o hücreye ait açıklamada, o hücrede yaptığın değişiklik "tarih / eğişiklik" şeklinde kendiliğinden eklenir.

ID : 1028
ISLEM : hücre değerleri belli tabloda otomatik renklendirmeli seçme
MAKRO KODU : Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("A1") = False Then Exit Sub ' Optional On Error Resume Next Dim myRange As Range Dim myTopLeftCell As Range Dim myBottomRightCell As Range ' Set your Top Left Cell and Bottom Right Cell, (Range Names can be used also) ' **************************************************************** Set myTopLeftCell = Range("B3") Set myBottomRightCell = Range("H17") ' **************************************************************** If Target.Row >= myTopLeftCell.Row And _ Target.Offset(Selection.Rows.Count - 1).Row <= myBottomRightCell.Row And _ Target.Column >= myTopLeftCell.Column And _ Target.Offset(, Selection.Columns.Count - 1).Column <= myBottomRightCell.Column Then Set myRange = Selection If ActiveSheet.Shapes("hSelection") Is Nothing Then ActiveSheet.Shapes.AddShape(msoShapeRectangle, myTopLeftCell.Left, Selection.Top, _ myBottomRightCell.Offset(, 1).Left - _ myTopLeftCell.Left, Selection.Height).Select With Selection With .ShapeRange .Fill.Visible = msoFalse .Line.ForeColor.SchemeColor = 12 ' Change Color Here .Line.Weight = 2.25 ' Change Line Weight (Thickness) Here .ZOrder msoSendToBack .Shadow.Visible = msoFalse End With .Name = "hSelection" .PrintObject = False End With Else With ActiveSheet.Shapes("hSelection") .Left = myTopLeftCell.Left .Top = Selection.Top .Width = myBottomRightCell.Offset(, 1).Left - myTopLeftCell.Left .Height = Selection.Height .ShapeRange.Shadow.Visible = msoFalse End With End If myRange.Select End If Set myTopLeftCell = Nothing Set myBottomRightCell = Nothing Set myRange = Nothing End Sub

ID : 1029
ISLEM : hücre değiştiğinde yaninda ki hücreye tarih yazsin
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target = 0 Then Exit Sub Application.EnableEvents = False Target.Offset(0, 1) = Now Application.EnableEvents = True End Sub

ID : 1030
ISLEM : hücre değiştirilemez uyarısı, diğer hücreye yönlendirme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If ActiveCell.Column = 11 Then Msg = "Bu bölümdeki bilgileri değiştiremezsin!" Cvp = MsgBox(Msg) Application.Undo Else End If If ActiveCell.Column = 12 Then Msg = "Bu bölümdeki bilgileri değiştiremezsin! " Cvp = MsgBox(Msg) Application.Undo Else End If End Sub

ID : 1031
ISLEM : hücre dolu ise boş hücreye aktar
MAKRO KODU : Dim satirsay As Integer satirsay = Application.CountA(Sheets("sayfa1").Columns("A")) if satirsay=0 then Sheets("sayfa1").Cells(1, 1)="ne yazılacaksa" else Sheets("sayfa1").Cells(2, 1)="ne yazılacaksa" end if

ID : 1032
ISLEM : hücre genişliğince kenarlık çizme
MAKRO KODU : Sub TextBox2Cell() With ActiveCell ActiveSheet.Shapes.AddTextbox _ msoTextOrientationHorizontal, .Left, _ .Top, .Width, .Height End With End Sub

ID : 1033
ISLEM : hücre genişliğince kenarlık çizme2
MAKRO KODU : Sub TextBox2Selection() If TypeName(Selection) = "Range" Then With Selection ActiveSheet.Shapes.AddTextbox _ msoTextOrientationHorizontal, .Left, _ .Top, .Width, .Height End With End If End Sub

ID : 1034
ISLEM : hücre içeriğine ekleme yap karşilaştir.
MAKRO KODU : verilen ilk koda dikkat etti iseniz Kod: Sub Macro1() For i = 1 To 20 bir = Cells(i, 1) [b]' 20 kez işlem yapar[/b] For j = 1 To 20 iki = Cells(j, "2&" Total") [b]'400 kez bu işlemi [/b] If bir = iki Then [b]'400 kez bu kontrolü [/b] Cells(j, 4) = "eşit" [b]'400 kez bu işlemi yapar[/b] Next j Next i End Sub gereksiz 1200 işlem yaptığını görmüşünüzdür.

ID : 1035
ISLEM : hücre içeriğinin silinmesi
MAKRO KODU : Range(“D2:E5”).Clear

ID : 1036
ISLEM : hücre içerisinde kayan yazı
MAKRO KODU : Sub YANIPSON() Dim durum As Boolean, i As Single Do While (True) If durum=True Then Range("C1").Select With Selection.Interior .ColorIndex=3 .Pattern=xlSolid End With For i =0 To 2500 DoEvents Next durum=False Else Range("C1").Select Selection.Interior.ColorIndex=xlNone For i=0 To 2500 DoEvents Next durum=True End If Loop End Sub

ID : 1037
ISLEM : hücre içerisindeki boşluklari silmek
MAKRO KODU : Columns("H").Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart

ID : 1038
ISLEM : hücre içerisine kelime ekleme
MAKRO KODU : Sub InserTermineDansCellule() Cells(1, 1).Select With Selection .Characters(.Characters.Count + 1).Insert (" terminé") End With End Sub

ID : 1039
ISLEM : hücre isimlerini öğrenme
MAKRO KODU : Sub a() Dim Nm As Name For Each Nm In Names Nm.Visible = True Next End Sub Sub ShowNames() Dim N As Integer For N = 1 To ActiveWorkbook.Names.Count On Error Resume Next Cells(N, 1) = "'" & ActiveWorkbook.Names(N).Nam

ID : 1040
ISLEM : hücre ismi ile tarihli ve tarihsiz kitap kaydetme
MAKRO KODU : Sub range_date_save () Dim dName$ dName = Worksheets(1).Range("A1") dName = Format(dName, "mmdd") & ".xls" ActiveWorkbook.SaveAs dName End Sub Sub range_save() ThisWorkbook.SaveAs FileName:=Worksheets(1).Range("A1") End Sub

ID : 1041
ISLEM : hücre kopyalama
MAKRO KODU : Sub CopyRange() Range("A1:A3").Copy Destination:=ActiveCell End Sub

ID : 1042
ISLEM : hücre kopyalama
MAKRO KODU : Sub copy() Sheets("Sayfa1").Range("A1:A3").copy Destination:=ActiveCell End Sub

ID : 1043
ISLEM : hücre koruma penceresi
MAKRO KODU : Sub Dialog_10() Application.Dialogs(xlDialogCellProtection).Show End Sub

ID : 1044
ISLEM : hücre renkleri ile ilgili kodlar
MAKRO KODU : Eğer A sütununda kırmızı hücre varsa ilgili satırı siler (Color index = 3 :Kırmızı) Sub kirmizisil() Sub DeleteRowsRedInColA() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim rng As Range, ix As Long Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange) For ix = rng.Count To 1 Step -1 If rng.Item(ix).Interior.ColorIndex = 3 Then 'rakamı değiştirebilirsiniz rng.Item(ix).EntireRow.Delete End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 'Dolu hücrelerin satırını mavi, boşları ise sarı yapan kodlar Sub bosdolurenklendir() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range For Each cell In Intersect(Selection, ActiveCell.EntireColumn, _ ActiveSheet.UsedRange) Select Case cell.Value Case Is >= 50 cell.EntireRow.Interior.ColorIndex = 20 Case Is >= 40 cell.EntireRow.Interior.ColorIndex = 37 Case Is >= 20 cell.EntireRow.Interior.ColorIndex = 38 Case Is >= 0 cell.EntireRow.Interior.ColorIndex = 36 Case Else cell.EntireRow.Interior.ColorIndex = 44 End Select Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 'A1:B10 hücrelerindeki değer 10 dan büyükse hücre sarı olur Private Sub Worksheet_Change( _ ByVal Target As Excel.Range) If Intersect(Target, Range("A1:B10")) _ Is Nothing Then Exit Sub If Target.Value > 10 Then Target.Interior.ColorIndex = 6 Else Target.Interior.ColorIndex = xlNone End If End Sub

ID : 1045
ISLEM : hücre renkleri ile ilgili kodlar
MAKRO KODU : EĞER A SÜTUNUNDA KIRMIZI HÜCRE VARSA İLGİLİ SATIRI SİLEN KODLAR (COLOR İNDEK = 3 :Kırmızı) Sub kirmizisil() Sub DeleteRowsRedInColA() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim rng As Range, ix As Long Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange) For ix = rng.Count To 1 Step -1 If rng.Item(ix).Interior.ColorIndex = 3 Then 'rakamı değiştirebilirsiniz rng.Item(ix).EntireRow.Delete End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub DOLU HÜCRELERİN SATIRINI MAVİ BOŞLARI İSE SARI YAPAN KODLAR Sub bosdolurenklendir() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range For Each cell In Intersect(Selection, ActiveCell.EntireColumn, _ ActiveSheet.UsedRange) Select Case cell.Value Case Is >= 50 cell.EntireRow.Interior.ColorIndex = 20 Case Is >= 40 cell.EntireRow.Interior.ColorIndex = 37 Case Is >= 20 cell.EntireRow.Interior.ColorIndex = 38 Case Is >= 0 cell.EntireRow.Interior.ColorIndex = 36 Case Else cell.EntireRow.Interior.ColorIndex = 44 End Select Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub A1:B10 HÜCRELERİNDEKİ DEĞER 10 DAN BÜYÜK İSE HÜCRE RENGİ SARI OLUR Private Sub Worksheet_Change( _ ByVal Target As Excel.Range) If Intersect(Target, Range("A1:B10")) _ Is Nothing Then Exit Sub If Target.Value > 10 Then Target.Interior.ColorIndex = 6 Else Target.Interior.ColorIndex = xlNone End If End Sub

ID : 1046
ISLEM : hücre seçilince şifreli giriş
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Selection.Cells.Address = "e26:ı36" Then Exit Sub şifre = InputBox("lütfen şifreyi giriniz") If şifre <> "a" Then [e2].Select End Sub

ID : 1047
ISLEM : hücre seçilince şifreli giriş
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) sut = Selection.Cells.Column sat = Selection.Cells.Row If sut < 5 Or sut > 9 Or sat < 26 Or sat > 36 Then Exit Sub şifre = InputBox("lütfen şifreyi giriniz") If şifre <> "a" Then [a2].Select End Sub

ID : 1048
ISLEM : hücre seçme,tanımlama
MAKRO KODU : Sub Düğme1_Tıklat() Dim r1 As Range, r2 As Range, myMultiAreaRange As Range Set r1 = Range("A1:B2") Set r2 = Range("C3:D4") Set myMultiAreaRange = Union(r1, r2) myMultiAreaRange.Select End Sub

ID : 1049
ISLEM : hücre sürüklemesini engelle, aktif yap
MAKRO KODU : Sub SuruklemeyiEngelle() Application.CellDragAndDrop = False End Sub 'sürüklemeyi aktif yap Sub Auto_Close() Application.CellDragAndDrop = True End Sub

ID : 1050
ISLEM : hücre sürüklenmesini engelle & aktif yap
MAKRO KODU : HÜCRE SÜRÜKLENMESİNİ ENGELLE Sub SuruklemeyiEngelle() Application.CellDragAndDrop = False End Sub HÜCRE SÜRÜKLENMESİNİ AKTİF YAP Sub Auto_Close() Application.CellDragAndDrop = True End Sub