Makro Kod Listesi

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

ID : 1051
ISLEM : hücre tanımlayarak yazıcıdan çıktı alma
MAKRO KODU : Sub ImpZoneEtTitle() With Worksheets("Sayfa1").PageSetup .CenterHorizontally = True .PrintArea = "$A$10:$G$15" .PrintTitleRows = ("$A$1:$A$2") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets("Sayfa1").PrintOut End Sub

ID : 1052
ISLEM : hücre tanimlamalarini sayfaya göre ayarlama
MAKRO KODU : Private Sub cmdkaydet_Click() Dim bak As Range Dim say As Integer For Each bak In Range("A1:A" & WorksheetFunction.CountA(sheets("veriler").Range("A1:A65000"))) ---------------------------------------------------- txtceksirano.Value = WorksheetFunction.Count(sheets("veriler").Range("A1:A65000")) + 1

ID : 1053
ISLEM : hücre ve sütun seçimleri
MAKRO KODU : AKTİF SÜTUNU SEÇ Sub SelectEntireColumn() Selection.EntireColumn.Select End Sub AKTİF SATIRI SEÇ Sub SelectEntireRow() Selection.EntireRow.Select End Sub TÜM HÜCRELERİ SEÇ Sub SelectEntireSheet() Cells.Select End Sub DOLU HÜCRELERİN ALTINDAKİ BOŞ HÜCREYİ SEÇER Sub ActivateNextBlankDown() ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub AKTİF HÜCRELERİN SAĞ TARAFINDAKİ BOŞ HÜCREYİ SEÇER Sub ActivateNextBlankToRight() ActiveCell.Offset(0, 1).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(0, 1).Select Loop End Sub AKTİF HÜCRENİN SAĞINDAKİ VE SOLUNDAKİ DOLU HÜCRELERİ SEÇER 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 AKTİF HÜCRENİN ALTINDAN BAŞLAYARAK EN SON HÜCREYE KADAR SEÇER Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select End Sub A1:A3 VE C3:C8 HÜCRE ARALIĞINI SEÇER Sub hucresec() Application.ScreenUpdating = False Dim r1 As Range, r2 As Range, rAll As Range Set r1 = Range("A1", "A3") Set r2 = Range("C3", "C8") Set rAll = Union(r1, r2) rAll.Select End Sub Aktif hücrenin 3 satır altındaki, iki sütun önündeki hücreyi seçer Sub MoveToCell() ActiveCell.Offset(3, 2).Select End Sub

ID : 1054
ISLEM : hücre veya hücreleri kopyalama
MAKRO KODU : Sub CopyOneArea() Dim sourceRange As Range Dim destrange As Range Dim Lr As Long Lr = LastRow(Sheets("Sayfa1")) + 1 Set sourceRange = Sheets("Sayfa1").Range("A1:c10") Set destrange = Sheets("Sayfa2").Range("A" & Lr) sourceRange.Copy destrange End Sub Sub CopyOneAreaValues() Dim sourceRange As Range Dim destrange As Range Dim Lr As Long Lr = LastRow(Sheets("Sayfa2")) + 1 Set sourceRange = Sheets("Sayfa1").Range("A1:c10") With sourceRange Set destrange = Sheets("Sayfa2").Range("A" & Lr). _ 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

ID : 1055
ISLEM : hücre, sütun seçimleri
MAKRO KODU : Aktif sütunu seç Sub SelectEntireColumn() Selection.EntireColumn.Select End Sub 'Aktif satırı seç Sub SelectEntireRow() Selection.EntireRow.Select End Sub 'Tüm hücreleri seç Sub SelectEntireSheet() Cells.Select End Sub 'Dolu hücrelerin altındaki boş hücreyi seç Sub ActivateNextBlankDown() ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'Aktif hücrenin sağ tarafındaki boş hücreyi seç Sub ActivateNextBlankToRight() ActiveCell.Offset(0, 1).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(0, 1).Select Loop End Sub 'Aktif hücrenin sağındaki ve solundaki dolu hücreleri seçer 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 'Aktif hücrenin altından başlayarak en son hücreye kadar seç Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select End Sub 'A1:A3 VE C3:C8 hücre aralığını seç Sub hucresec() Application.ScreenUpdating = False Dim r1 As Range, r2 As Range, rAll As Range Set r1 = Range("A1", "A3") Set r2 = Range("C3", "C8") Set rAll = Union(r1, r2) rAll.Select End Sub 'Aktif hücrenin 3 satır altındaki, iki sütun önündeki hücreyi seçer Sub MoveToCell() ActiveCell.Offset(3, 2).Select End Sub

ID : 1056
ISLEM : hücre_bicimlendir_saydirma (dalga geçme)
MAKRO KODU : Sub hücre_bic_say() For n = 100 To 1 Step -1 Application.StatusBar = n SendKeys "{Tab}" For i = 1 To 11 SendKeys "{down}" Next SendKeys "{Tab}" SendKeys "{Tab}" For i = 1 To n SendKeys "{down}" Next SendKeys "%l" SendKeys "{Enter}" Application.Dialogs(xlDialogFormatNumber).Show Next Application.StatusBar = False End Sub

ID : 1057
ISLEM : hücrede 0 (sıfır) varsa durur yoksa atlar
MAKRO KODU : Do While Not IsEmpty(ActiveCell) And ActiveCell <> "" And ActiveCell <> 0 ActiveCell.Offset(1, 0).Select Loop

ID : 1058
ISLEM : hücrede ad soyad'ları 2 textbox'ta göstermek
MAKRO KODU : Sub ayır() b = Split(Range("a1").Value, " ") If UBound(b) > 1 Then TextBox1 = b(0) & " " & b(1) TextBox2 = b(2) Else TextBox1 = b(0) TextBox2 = b(1) End If End Sub

ID : 1059
ISLEM : hücrede ay öğrenme (fonksiyon tanımlayarak)
MAKRO KODU : Örnek kullanım 1 'a1 =1 'b1==aycevir(A1) 'Örnek kullanım 2 'a2=02.02.2006 'b2=aycevir(AY(A2)) Function AyCevir(deger As Byte) AyCevir = Choose(deger, "Ocak", "Şubat", "Mart", "Nisan", "Mayıs", "Haziran", _ "Temmuz", "Ağustos", "Eylül", "Ekim", "Kasım", "Aralık") End Function

ID : 1060
ISLEM : hücrede bir sonraki ayın gün sayısı kadar gün ilave etme
MAKRO KODU : Private Sub CommandButton1_Click() For i = 2 To 100 ay = DatePart("m", DateAdd("m", 1, Cells(i - 1, 2))) yıl = DatePart("yyyy", DateAdd("m", 1, Cells(i- 1, 2))) For k = 28 To 31 yeni = DateAdd("d", k, "1/" & ay & "/" & yıl) If ay <> DatePart("m", yeni) Then Exit For Next k Cells(i, 2) = DateAdd("d", k, Cells(i - 1, 2)) Next i End Sub Burada A2 ile A100 arasına A1 deki tarih baz alınarak uygun tarihler yerleştirildi. Ama baktım, bu işte bir gariplik var dedim. Bu kadar basit bir işlemi Excel fonksiyonları çözümlemeli diyerek formüllerimi kurcaladım biraz. Eğer ToolPak-VBA Çözümleyicisi eklentisi aktif ise sizin formülleriniz içinde de EoMonth formülünü bulacaksınız. =EoMonth(ReferansTarih,İstenilenAy) Referans Tarih = Yeni tarihi bulmak için üzerine ilave etmek istediğiniz tarih değeri. İstenilen Ay = Gün sayısını öğrenmek istediğiniz ayı belirtecek olan ve ReferansTarih ten sonraki ayı belirten Tamsayı değişken. Bu Durumda A2 hücresine = A1+EoMonth(A1;1) A3 hücresine = A2+EoMonth(A2;1) ve bu şekilde devam edildiğinde istenilen çözüm bulunmuş oluyor.

ID : 1061
ISLEM : hücrede enter a basınca makro çalıştırma
MAKRO KODU : Sub auto_open() Call Ereignis End Sub Sub Ereignis() Sheets("Sayfa1").OnEntry = "färben" End Sub Sub färben() Farbzahl = Range("C6") Range("B2:D5").Select With Selection.Interior .ColorIndex = Farbzahl End With Range("C5").Select End Sub Sub auto_close() Worksheets("Sayfa1").OnEntry = "" End Sub

ID : 1062
ISLEM : hücrede entere basılıncs direk sayfaya gitme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [a4]) Is Nothing Then Exit Sub If Target <> "" Then Sheets("" & [a4]).Select End Sub

ID : 1063
ISLEM : hücrede ilk harfler büyük 1
MAKRO KODU : Option Explicit Sub ChangeText_Proper() Dim cCell As Range Dim TheRg As Range '// Incase No constants of type text in the selection! On Error Resume Next Set TheRg = Selection.SpecialCells(xlCellTypeConstants, 2) If TheRg Is Nothing Then MsgBox "Yazı yok mu desem!", vbCritical: Exit Sub On Error GoTo 0 For Each cCell In TheRg cCell = Application.WorksheetFunction.Proper(cCell) Next MsgBox "Tamam!", vbInformation End Sub

ID : 1064
ISLEM : hücrede ilk harfler büyük 2
MAKRO KODU : Sayfanın kod bölümüne 'İlk harfler büyük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.Proper(Target.Value) End Sub 'Hepsi Büyük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.UPPER(Target.Value) End Sub 'Hepsi Küçük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.Lower(Target.Value) End Sub

ID : 1065
ISLEM : hücrede isim küçük harfli ise o hücreyi silme
MAKRO KODU : Sub kucuksil() Dim gg as double gg = Application.worksheetFunction.CountA(Range("A:A")) For i = 1 to gg if LCase(Cells(i,1).text) = Cells(i,1).text then Cells(i,1).value="" Else End if Next i End sub

ID : 1066
ISLEM : hücrede isim küçük harfli ise o satırı silme
MAKRO KODU : Sub sil() For i = 1 To 500 If LCase(Cells(i, 1).Text) = Cells(i, 1).Text Then Application.DisplayAlerts = False Cells(i, 1).EntireRow.Delete If Not ActiveCell.Value = "" Then i = i - 1 Application.DisplayAlerts = True End If Next i MsgBox "Satır Silme İşlemi Tamamlanmıştır." End Sub

ID : 1067
ISLEM : hücrede karakter say
MAKRO KODU : Sub hucresaymesaj() pir = [a1] MsgBox Len(pir) End Sub

ID : 1068
ISLEM : hücrede kelimelerin ilk harfi büyük
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Static dur As Boolean If Target.Address = "$A$4" And dur = False Then dur = True Target.Value = UCase(Left(LTrim(Target.Value), 1)) & Right(LTrim(Target.Value), Len(LTrim(Target.Value)) - 1) End If dur = False End Sub

ID : 1069
ISLEM : hücrede saat
MAKRO KODU : Private Sub Worksheet_Activate() Do DoEvents [a1] = Format(Now, "hh:mm:ss") Loop End Sub

ID : 1070
ISLEM : hücrede saat (hücreye ad tanımlayarak)
MAKRO KODU : Private Sub Workbook_Open() Call Ayar End Sub Sub Ayar() Dim Zaman As Date Zaman = Now + TimeValue("00:00:01") Application.ontime Zaman, "Yenile" End Sub Sub Yenile() Range("Saat").Value = Now Call Ayar End Sub

ID : 1071
ISLEM : hücrede saat saydırma
MAKRO KODU : Sub clock() If ThisWorkbook.Worksheets(1).Range("B1").Value = "X" Then Exit Sub ThisWorkbook.Worksheets(1).Range("A1").Value = Format(Now, "hh:mm:ss AM/PM") Application.OnTime Now + TimeSerial(0, 0, 1), "clock" End Sub

ID : 1072
ISLEM : hücrede saat saydırma
MAKRO KODU : Sub Heure() Application.OnTime Now + TimeValue("00:00:01"), "Heure" Range("A1") = Time End Sub Sub Arret() Application.OnTime Now + TimeValue("00:00:01"), "Heure", , False End Sub

ID : 1073
ISLEM : hücrede saat saydırma-durdurma
MAKRO KODU : Dim stopit As Boolean 'on top of module! Sub startclock() 'assign start button stopit = False clock End Sub Sub clock() If stopit = True Then Exit Sub ActiveWorkbook.Worksheets(1).cells(1, 1).Value = _ Format(Now, "hh:mm:ss") Application.OnTime (Now + TimeSerial(0, 0, 1)), "clock" End Sub Sub stopclock() 'assign stop button stopit = True End Sub

ID : 1074
ISLEM : hücrede takvim (calendar) açma
MAKRO KODU : Sayfaya bir Calendar ekle ve adı Calendar1 olsun. Sonra 'ThisWorkbook ' un Open event ine : Private Sub Workbook_Open() Calendar1.Visible = False End Sub 'Bunu da olayın gerçekleşmesini istediğin sayfanın kod bölümüne Private Sub Calendar1_Click() ActiveCell.Value = Calendar1.Value End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = Range("A2").Address Then Calendar1.Visible = True Else Calendar1.Visible = False End If End Sub

ID : 1075
ISLEM : hücrede yazılı sayfa var mı yok mu bulur
MAKRO KODU : Sub SayfaAra() Dim i As Integer For i = 1 To Worksheets.Count If Worksheets(i).Name = Range("B5").Value Then MsgBox "Bu isimde bir sayfa var" Exit Sub End If Next i End Sub

ID : 1076
ISLEM : hücredeki açıklamayı textbox'a alma
MAKRO KODU : TextBox1 = Sheets("Sayfa2").Range("A21").Comment.Text

ID : 1077
ISLEM : hücredeki ad soyadı ayırmak
MAKRO KODU : A Stünu B Stünu C Stünu Sub hücre_ayir() Dim AD As String Dim SOYAD As String For HÜCRE = 1 To 1000 'DÖNGÜ SAYISINI SİZ VEREBİLİRSİNİZ. BURADA 1000 ALINDI Range("A" & HÜCRE).Select UZUNLUK = Len(Range("A" & HÜCRE).Text) 'BAŞVURULAN HÜCRENİN METİN UZUNLUĞU For KARAKTER = 1 To UZUNLUK If Mid(Range("A" & HÜCRE), KARAKTER, 1) = " " Then 'EĞER BAKILAN KARAKTER " " İSE AYIRMA İŞLEMİ YAPILACAK VE BİR SONRAKİ HÜCREYE GEÇİLECEK AD = Left(Range("A" & HÜCRE), KARAKTER - 1) SOYAD = Mid(Range("A" & HÜCRE), KARAKTER + 1, UZUNLUK - Len(AD)) '+1 VE -1 LER BOŞLUĞU ALMAMAK İÇİN EKLENDİ Range("B" & HÜCRE).Value = AD Range("C" & HÜCRE).Value = SOYAD Exit For End If Next KARAKTER Next HÜCRE Range("A1").Select End Sub

ID : 1078
ISLEM : hücredeki adrese ping atma
MAKRO KODU : Sub GetIPs() Dim c As Range 'Range("A2:A4") contains the domain names to ping For Each c In ActiveSheet.Range("A2:A4") c.Offset(0, 1) = PingAddress(c.Text) Next c End Sub Function PingAddress(strDomain As String) As String Dim fso As Object Dim WshShell As Object Dim RetVal As Long Dim strTemp As String Dim colOutput As New Collection Dim OutputItem Dim i As Long Set WshShell = CreateObject("Wscript.Shell") RetVal = WshShell.Run("cmd /c nslookup.exe -ls " & strDomain & " > C:\NSLOOKUPDATA.TXT", 0, True) Set fso = CreateObject("Scripting.FileSystemObject") Set txtstream = fso.OpenTextFile("C:\NSLOOKUPDATA.TXT", 1) Do strTemp = txtstream.ReadLine colOutput.Add strTemp Loop Until txtstream.AtEndOfStream txtstream.Close For i = colOutput.Count To 1 Step -1 If Left(colOutput(i), 10) = "Addresses:" Then strTemp = Trim(colOutput(i)) PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, "Addresses:") - 9)) Exit For End If Next If PingAddress = "" Then For i = colOutput.Count To 1 Step -1 If Left(colOutput(i), 8) = "Address:" Then strTemp = Trim(colOutput(i)) PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, "Addresses:") - 9)) Exit For End If Next End If If PingAddress = "" Then PingAddress = "Domain name not resolved" Set txtstream = Nothing Set fso = Nothing Set WshShell = Nothing End Function

ID : 1079
ISLEM : hücredeki değere göre makro çalıştırma
MAKRO KODU : Sayfanın kod bölümüne, Mahmut yazarsan Makro1'i çalıştırır. Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target = "Mahmut" Then Run "Module1.Makro1" End If End Sub

ID : 1080
ISLEM : hücredeki değere göre mesaj veya makro
MAKRO KODU : Private Sub Worksheet_Calculate() Worksheet_Change Range("VB_Trigger") End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) ' Level 1: Set up the event to watch a single cell. If Target.Address = Range("VB_Trigger").Address Then ' Level 2: Perform some action based on the value of the watched cell. Select Case Target.Value Case 1 MsgBox "Hello" Case 2 MsgBox "Goodbye" Case 3 MsgBox "Pretty Bird" End Select End If End Sub