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


a1:a10 hücreleri arasında 10 olanları 21 yapar

ID : 121
ISLEM : a1:a10 hücreleri arasında 10 olanları 21 yapar
MAKRO KODU : Sub degistir() Dim CurCell As Range For Each CurCell In Range("A1:A10") If CurCell.Value = 10 Then CurCell.Value = 21 Next End Sub

a1:a10 hücreleri arasındaki boş hücreleri yeşile boyar

ID : 122
ISLEM : a1:a10 hücreleri arasındaki boş hücreleri yeşile boyar
MAKRO KODU : Sub BackgroundColors() For Each cell In Range("a1:a10") If Not IsError(cell.Value) Then With cell.Interior Select Case cell.Value Case Is = Empty .ColorIndex = 10 Case Is = "?" .ColorIndex = 6 Case Else .ColorIndex = 0 'xlAutomatic End Select End With Else cell.Interior.ColorIndex = xlAutomatic End If Next cell End Sub

a1:a10 hücreleri arasindaki boş hücreleri yeşile boyar

ID : 123
ISLEM : a1:a10 hücreleri arasindaki boş hücreleri yeşile boyar
MAKRO KODU : Açıklama: a1:a10 Hücreleri arasındaki boş hücreleri yeşile boyar Kod: Sub BackgroundColors() For Each cell In Range("a1:a10") If Not IsError(cell.Value) Then With cell.Interior Select Case cell.Value Case Is = Empty .ColorIndex = 10 Case Is = "?" .ColorIndex = 6 Case Else .ColorIndex = 0 'xlAutomatic End Select End With Else cell.Interior.ColorIndex = xlAutomatic End If Next cell End Sub

a1:a10 topla mesaj ver toplamını a11 e yaz

ID : 124
ISLEM : a1:a10 topla mesaj ver toplamını a11 e yaz
MAKRO KODU : Sub SommePositive() For Each Cell In Range("A1:A10") If Cell.Value > 0 Then total = total + Cell End If Next MsgBox "Total des valeurs positives " & total Range("A11") = total End Sub

a1:a1000 arası aynısını yama

ID : 125
ISLEM : a1:a1000 arası aynısını yama
MAKRO KODU : Option Explicit Sub Macro2() Dim buf As Variant Dim i As Long 'Get values as an array buf = Range("A1:A10000").Value 'loop through the array and add a string to each element For i = LBound(buf, 1) To UBound(buf, 1) buf(i, 1) = buf(i, 1) & " - modified" Next 'Put the array back into the worksheet Range("A1:A10000").Value = buf End Sub

a1:a30 sınıf adı, b1-b30 sınıfı 2 comboboxta gösterimi

ID : 126
ISLEM : a1:a30 sınıf adı, b1-b30 sınıfı 2 comboboxta gösterimi
MAKRO KODU : Private Sub ComboBox1_Change() ComboBox2 = "" If ComboBox1 = "1 A Sınıfı" Then ComboBox2.RowSource = "1!b2:b40" ElseIf ComboBox1 = "1 B Sınıfı" Then ComboBox2.RowSource = "1!d2:d40" ElseIf ComboBox1 = "1 C Sınıfı" Then ComboBox2.RowSource = "1!f2:f40" End If End Sub Private Sub UserForm_Initialize() ComboBox1.MatchEntry = fmMatchEntryComplete ComboBox2.MatchEntry = fmMatchEntryComplete ComboBox1.AddItem "1 A Sınıfı" ComboBox1.AddItem "1 B Sınıfı" ComboBox1.AddItem "1 C Sınıfı" End Sub

a1:a5 e sayı yaz c1 e de bunların toplamı 100 değilse uyarı verir

ID : 127
ISLEM : a1:a5 e sayı yaz c1 e de bunların toplamı 100 değilse uyarı verir
MAKRO KODU : Option Explicit Private Sub Worksheet_Calculate() ' Target value: Const lVal As Long = 100 Dim rCell As Range ' Put the cell you want to look at here ' Cell must be a formula!! Set rCell = Range("C1") ' If the target cells value rises above the specified target value, If rCell.Value > lVal Then ' then deliver a message MsgBox "Target value is above " & lVal, 16, "Too High!" ' And step backwards Application.Undo End If ' Explicitly clear memory Set rCell = Nothing End Sub

a1:a5 e sayı yaz c1 e de bunların toplamı 100 ise uyarı verir

ID : 128
ISLEM : a1:a5 e sayı yaz c1 e de bunların toplamı 100 ise uyarı verir
MAKRO KODU : Option Explicit Private Sub Worksheet_Calculate() ' Target value: Const lVal As Long = 100 Dim rCell As Range ' Put the cell you want to look at here ' Cell must be a formula!! Set rCell = Range("C1") ' If the target cells value equals the specified target value, If rCell.Value = lVal Then ' then deliver a message MsgBox "Target value of " & lVal & " has been achieved", 64, "Target Met!" End If ' Explicitly clear memory Set rCell = Nothing End Sub

a1:a5 e sayı yaz c1 e de bunların toplamı 100den aşağı ise uyarı verir

ID : 129
ISLEM : a1:a5 e sayı yaz c1 e de bunların toplamı 100den aşağı ise uyarı verir
MAKRO KODU : Option Explicit Private Sub Worksheet_Calculate() ' Target value: Const lVal As Long = 100 Dim rCell As Range ' Put the cell you want to look at here ' Cell must be a formula!! Set rCell = Range("C1") ' If the target cells value drops below the specified target value, If rCell.Value -

a1:a5 verileri ile birlikte ait olunan ay ve yıl isimli yeni sayfa ekler

ID : 130
ISLEM : a1:a5 verileri ile birlikte ait olunan ay ve yıl isimli yeni sayfa ekler
MAKRO KODU : Sub Add_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = Format(Now, "mmmm_yyyy") For Each wSht In Worksheets If wSht.Name = shtName Then MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again." Exit Sub End If Next wSht Sheets.Add.Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) Sheets("Mahmut").Range("A1:A5").Copy _ Sheets(shtName).Range("A1") End Sub

a1:a50 ad soyadları textboxta arat listboxta listele

ID : 131
ISLEM : a1:a50 ad soyadları textboxta arat listboxta listele
MAKRO KODU : Private Sub CommandButton1_Click() Dim i As Integer ListBox1.Clear For i = 1 To 50 If StrConv(Cells(i, 1), vbUpperCase) = StrConv(TextBox1, vbUpperCase) Then ListBox1.AddItem Cells(i, 1).Text & " - " & Cells(i, 1).Address(False, False) End If Next i End Sub

a1:a50 adları textboxta arat listboxta listele

ID : 132
ISLEM : a1:a50 adları textboxta arat listboxta listele
MAKRO KODU : Private Sub CommandButton2_Click() Dim i As Integer Dim say As Integer ListBox1.Clear Set isim = Range("A1:A50").Find(TextBox1) If Not isim Is Nothing Then ilk = isim.Address Do ListBox1.AddItem isim & " - " & isim.Address(False, False) Set isim = Range("A1:A50").FindNext(isim) Loop While Not isim Is Nothing And isim.Address ilk End If End Sub -

a1:af12 hücreleri arasındaki veriler yanıp söner

ID : 133
ISLEM : a1:af12 hücreleri arasındaki veriler yanıp söner
MAKRO KODU : Sub FlashFont() 'Joe Was 'Make cell range font flash, x times, x fast, in x color, 'when Ctrl-z is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range font flash! Set myCell = Range("A1:AF12") Application.DisplayStatusBar = True Application.StatusBar = "... Şu an flash yazı gösterisi var lütfen biraz bekleyin...! " 'Make cell font flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 3 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.3 'Make cell flash, this many times! Do Until x = 15 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = xlAutomatic Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub Sub reSetFlash() 'Re-set cell range color if edit break on color, Ctrl-r to re-set! ActiveCell.Select Selection.Interior.ColorIndex = xlNone End Sub

a1:af12 hücreleri arasindaki veriler yanip söner

ID : 134
ISLEM : a1:af12 hücreleri arasindaki veriler yanip söner
MAKRO KODU : Açıklama: A1:AF12 hücreleri arasındaki veriler yanıp söner Kod: Sub FlashFont() 'Joe Was 'Make cell range font flash, x times, x fast, in x color, 'when Ctrl-z is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range font flash! Set myCell = Range("A1:AF12") Application.DisplayStatusBar = True Application.StatusBar = "... Şu an flash yazı gösterisi var lütfen biraz bekleyin...! " 'Make cell font flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 3 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.3 'Make cell flash, this many times! Do Until x = 15 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = xlAutomatic Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub Sub reSetFlash() 'Re-set cell range color if edit break on color, Ctrl-r to re-set! ActiveCell.Select Selection.Interior.ColorIndex = xlNone End Sub

a1:an1000 arasindaki text ile bulunan satirdaki dolu hücreleri listboxa atmak istiyorum

ID : 135
ISLEM : a1:an1000 arasindaki text ile bulunan satirdaki dolu hücreleri listboxa atmak istiyorum
MAKRO KODU : doğrudan listbox'a yerleştirmek bazen kafa karıştırabiliyor onun yerine aşağıdaki gibi diziye yerleştirirseniz daha rahat çalışırsınız.İstediğinizi yanlış anlamış olabilirim ama bu kodlar ile daha rahat modifiye edebilirsiniz istediğiniz şekle. Listbox'ınızın propertiesinde columncount'ıda kaç kolon olacaksa ona göre ayarlayın önce.. galiba 40.. Private Sub CommandButton1_Click() Dim satirda(100, 40) If Not TextBox1 = Empty Then Say = WorksheetFunction.CountA(Sheets("sayfa1").Range("l2:aj15000")) Set bulHucre = Sheets("sayfa1").Range("l2:aj" & Say).Find(TextBox1.Text, lookat:=xlPart) If bulHucre Is Nothing Then Exit Sub ilkAdres = bulHucre.Address ilksat = bulHucre.Row i = 0 Do While Not IsEmpty(bulHucre) i = i + 1 For t = 1 To 40 satirda(i, t) = Cells(ilksat, t) Next t Set bulHucre = Sheets("sayfa1").Range("l2:aj" & Say).FindNext(bulHucre) If bulHucre.Address = ilkAdres Then Exit Do ilkAdres = bulHucre.Address ilksat = bulHucre.Row Loop End If ListBox1.List = satirda() Set bulHucre = Nothing End Sub

a1:b10 hücrelerine ad tanımlar

ID : 136
ISLEM : a1:b10 hücrelerine ad tanımlar
MAKRO KODU : Sub AddName1() ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10" End Sub

a1:b5 arasına tıklayınca açılan userform 1

ID : 137
ISLEM : a1:b5 arasına tıklayınca açılan userform 1
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row -

a1:b5 arasına tıklayınca açılan userform 2

ID : 138
ISLEM : a1:b5 arasına tıklayınca açılan userform 2
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set MyIsect = Application.Intersect(Target, Range("A1:B5")) If Not MyIsect Is Nothing Then UserForm1.Show End Sub

a1:c10 arası veri girilince e1:e10 arasına tarihini ekler

ID : 139
ISLEM : a1:c10 arası veri girilince e1:e10 arasına tarihini ekler
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1:C11")) Is Nothing Then Application.EnableEvents = False Cells(Target.Row, 5).Value = Date Application.EnableEvents = True End If End Sub

a1:c10 arasının aynısını aktif hücreden itibaren yaz

ID : 140
ISLEM : a1:c10 arasının aynısını aktif hücreden itibaren yaz
MAKRO KODU : Sub CopyToActiveCell() Dim sourceRange As Range Dim destrange As Range If Selection.Cells.Count > 1 Then Exit Sub Set sourceRange = Sheets("Sayfa1").Range("A1:C10") Set destrange = ActiveCell sourceRange.Copy destrange End Sub Sub CopyToActiveCellValues() Dim sourceRange As Range Dim destrange As Range If Selection.Cells.Count > 1 Then Exit Sub Set sourceRange = Sheets("Sayfa1").Range("A1:C10") With sourceRange Set destrange = ActiveCell.Resize _ (.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Lastcol(sh As Worksheet) On Error Resume Next Lastcol = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 End Function

a1:d20 arasında kırmızı olan hücreleri toplar

ID : 141
ISLEM : a1:d20 arasında kırmızı olan hücreleri toplar
MAKRO KODU : Function SumIfColours(cellTextColour As Integer, _ Range1, ParamArray Range2()) As Double Dim objCell As Range ' Best to use this even if it does ' slow Excel down somewhat. Application.Volatile ' Initialise. SumIfColours = 0 ' Process first argument. ' Restrict the range to stop the loop looking ' at huge swathes of empty cells. For Each objCell In Intersect(Range1, _ Range1.Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell ' Process additional arguments (if any) If UBound(Range2) 0 Then For intArgument = 1 To UBound(Range2) For Each objCell In Intersect(Range2(intArgument), _ Range2(intArgument).Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell Next intArgument End If End Function D21 veya A1:D20 hücreleri dışında bir hücreye aşağıdaki fürmülü yazın. =SumIfColours(3;$A$1:$D$20) -

a1:d20 hücreleri arasindaki arka plan rengi kirmizi olan hücreleri toplar

ID : 142
ISLEM : a1:d20 hücreleri arasindaki arka plan rengi kirmizi olan hücreleri toplar
MAKRO KODU : Açıklama: A1:D20 hücreleri arasındaki arka plan rengi kırmızı olan hücreleri toplar Kod: Function SumIfColours(cellTextColour As Integer, _ Range1, ParamArray Range2()) As Double Dim objCell As Range ' Best to use this even if it does ' slow Excel down somewhat. Application.Volatile ' Initialise. SumIfColours = 0 ' Process first argument. ' Restrict the range to stop the loop looking ' at huge swathes of empty cells. For Each objCell In Intersect(Range1, _ Range1.Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell ' Process additional arguments (if any) If UBound(Range2) 0 Then For intArgument = 1 To UBound(Range2) For Each objCell In Intersect(Range2(intArgument), _ Range2(intArgument).Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell Next intArgument End If End Function D21 veya A1:D20 hücreleri dışında bir hücreye aşağıdaki fürmülü yazın. =SumIfColours(3;$A$1:$D$20) -

a1:d4 ü seç b2 yi active et

ID : 143
ISLEM : a1:d4 ü seç b2 yi active et
MAKRO KODU : Sub MakeActive() Worksheets("Sheet1").Activate Range("A1:D4").Select Range("B2").Activate End Sub

a1:h1 satırlarını diğer sayfalara da uygulatın

ID : 144
ISLEM : a1:h1 satırlarını diğer sayfalara da uygulatın
MAKRO KODU : Sub FillAll() Worksheets("Sheet2").Range("A1:H1") _ .Borders(xlBottom).LineStyle = xlDouble Worksheets.FillAcrossSheets (Worksheets("Sheet2") _ .Range("A1:H1")) End Sub

a1:j44 harici hücreleri gizleme

ID : 145
ISLEM : a1:j44 harici hücreleri gizleme
MAKRO KODU : Sub gizle() Columns("K:IV").Hidden = True Rows("45:65536").Hidden = True End Sub

a1:j44 harici hücreleri gösterme

ID : 146
ISLEM : a1:j44 harici hücreleri gösterme
MAKRO KODU : Sub göster() Columns("K:IV").Hidden = False Rows("45:65536").Hidden = False End Sub

a1:m8 hücrelerinin arkaplanı yanıp söner

ID : 147
ISLEM : a1:m8 hücrelerinin arkaplanı yanıp söner
MAKRO KODU : Sub FlashBack() 'Make cell range Background color, flash x times, x fast, in x color, 'when Ctrl-a is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range background flash! Set myCell = Range("A1:M8") Application.DisplayStatusBar = True Application.StatusBar = "... Select Cell to Stop and Edit or Wait for Flashing to Stop! " 'Make cell background flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 11 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.2 'Make cell flash, this many times! Do Until x = 2 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = xlNone Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub

a1=1 ise yanıp sönsün 0 ise dursun

ID : 148
ISLEM : a1=1 ise yanıp sönsün 0 ise dursun
MAKRO KODU : sayfanın kod bölümüne yapıştırın Option Explicit Public CellCheck As Boolean Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Range("A1") = "1" And CellCheck = False Then Call StartBlink CellCheck = True ElseIf Range("A1") "1" And CellCheck = True Then Call StopBlink CellCheck = False End If End Sub 'modüle yapıştırın Option Explicit Public RunWhen As Double Sub StartBlink() If Range("A1").Interior.ColorIndex = 3 Then Range("A1").Interior.ColorIndex = 6 Else Range("A1").Interior.ColorIndex = 3 End If RunWhen = Now + TimeSerial(0, 0, 1) Application.OnTime RunWhen, "StartBlink", , True End Sub Sub StopBlink() Range("A1").Interior.ColorIndex = xlAutomatic Application.OnTime RunWhen, "StartBlink", , False End Sub -

a1=1, c1=3, b sütunu ise gizli olsun. sayfa2 ye a1=1, b1=3 olur

ID : 149
ISLEM : a1=1, c1=3, b sütunu ise gizli olsun. sayfa2 ye a1=1, b1=3 olur
MAKRO KODU : Sub sichtbare_kopieren() Range("A1").CurrentRegion _ .SpecialCells(xlCellTypeVisible).Copy _ Worksheets("Tabelle2").Range("A1") End Sub

a16:g28 hücrelerini seçer ve 0 yapar

ID : 150
ISLEM : a16:g28 hücrelerini seçer ve 0 yapar
MAKRO KODU : Sub ResetTest2() For Each n In Range("A16:G28") If IsNumeric(n) Then n.Value = 0 End If Next n End Sub

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