Makro Kod Listesi

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

ID : 2071
ISLEM : tarih işlemleri 1
MAKRO KODU : Function ayekle(EklenecekSure As Integer, ilkTarih As Date) ayekle = DateAdd("m", EklenecekSure, ilkTarih) End Function Function yilekle(EklenecekSure As Integer, ilkTarih As Date) yilekle = DateAdd("yyyy", EklenecekSure, ilkTarih) End Function Function gunekle(EklenecekSure As Integer, ilkTarih As Date) gunekle = DateAdd("d", EklenecekSure, ilkTarih) End Function Function ayfarki(ilkTarih As Date, sonTarih As Date) ayfarki = DateDiff("m", ilkTarih, sonTarih) End Function Function yilfarki(ilkTarih As Date, sonTarih As Date) yilfarki = DateDiff("yyyy", ilkTarih, sonTarih) End Function Function gunfarki(ilkTarih As Date, sonTarih As Date) gunfarki = DateDiff("d", ilkTarih, sonTarih) End Function Function ayinsonu(tarih As Date) Dim ay As Integer Dim yil As Integer ay = Month(tarih) yil = Year(tarih) ayinsonu = IIf(ay = 2, IIf((yil Mod 4) > 0, 28, 29), IIf(ay = 4, 30, IIf(ay = 6, 30, IIf(ay = 9, 30, IIf(ay = 11, 30, 31))))) End Function Function yildakigun(tarih As Date) Dim yil As Integer yil = Year(tarih) yildakigun = IIf((yil Mod 4) > 0, 365, 366) End Function

ID : 2072
ISLEM : tarih işlemleri 2
MAKRO KODU : Function TarihEkle(Tarih As Date, Optional Gun As Integer, Optional Hafta As Integer, Optional Ay As Integer, Optional Yil As Integer) TarihEkle = DateAdd("d", Gun, Tarih) TarihEkle = DateAdd("ww", Hafta, TarihEkle) TarihEkle = DateAdd("m", Ay, TarihEkle) TarihEkle = DateAdd("yyyy", Yil, TarihEkle) End Function

ID : 2073
ISLEM : tarih ve sıra numarasına göre kayıt
MAKRO KODU : Private Sub Kaydet_Click() Sheets("Sayfa1").Select On Error Resume Next Dim i, r, y As Integer Dim s As String Dim q As Date s = txtyer For i = 5 To WorksheetFunction.CountA(Range("a2:a40")) + 1 If Cells(i, 1).Value = s Then q = txttarih For r = 5 To WorksheetFunction.CountA(Range("a3:AJ40")) + 1 If Cells(3, r).Value = q Then d = txtsonuç Cells(i, r).Value = d MsgBox "KAYIT TAMAMLANDI", , "KAYIT" Exit Sub End If Next r End If Next i MsgBox "ARANAN YER BULUNAMADI !" End Sub

ID : 2074
ISLEM : tarih yıln kaçıncı haftası
MAKRO KODU : Dim tarih As Date, hafta As Integer tarih = Date hafta = DatePart("ww", tarih, vbMonday, vbFirstJan1) MsgBox "Bugün: " & Date & " --> Yılın " & hafta & ". Haftası"

ID : 2075
ISLEM : tarihe göre kitap açma makrosu (belirlenen tarih geçmişse kitabı açmaz)
MAKRO KODU : Sub Auto_Open() Dim exdate As Date exdate = "11/30/2004" If Date > exdate Then MsgBox ("You have reached end of your trail period") ActiveWorkbook.Close End If MsgBox ("You have " & exdate - Date & "Days left") End Sub

ID : 2076
ISLEM : tarihi macroya metin olarak okuma.
MAKRO KODU : sub deneme() [d2].select selection.numberformat = "yyyy/mm/dd hh:mm:ss" end sub

ID : 2077
ISLEM : tarihi seriye çevirme
MAKRO KODU : Sub ConvertToDateSerial() 'Convert from recognizable US date to date serial 'For dates on/after March 1, 1900 back to dateserial Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next '-- in case no cells selected For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlCellTypeConstants)) cell.Value = Int(DateValue(cell.Value)) cell.NumberFormat = "general" Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

ID : 2078
ISLEM : tarihi tam gir o tarihten sonraki ve o yıl içerisindeki haftaları sayfa olarak eklesin
MAKRO KODU : Sub YearWorkbook() Dim iWeek As Integer Dim sht As Variant Dim sTemp As String Dim dSDate As Date sTemp = InputBox("Date for the first worksheet:", "End of Week?") dSDate = CDate(sTemp) Application.ScreenUpdating = False Worksheets.Add After:=Worksheets(Worksheets.Count), _ Count:=(52 - Worksheets.Count) For Each sht In Worksheets sht.Name = Format(dSDate, "dd-mmm-yyyy") dSDate = dSDate + 7 Next sht Application.ScreenUpdating = True End Sub

ID : 2079
ISLEM : tarihli hücrede eğer (ıf) makro
MAKRO KODU : Sub tarih() If [a1] = Date Then [b1] = 1 End If If [a1] = Date + 1 Then [b1] = 2 End If If [a1] = Date + 2 Then [b1] = 3 End If End Sub

ID : 2080
ISLEM : tarihli kopya
MAKRO KODU : Public Sub Dateikopie() Dim InI As Integer Workbooks.Add With ThisWorkbook ' Datei mit Code ActiveWorkbook.SaveAs .Path & "\Kopie_von" & ThisWorkbook.Name ' neue Datei Workbooks.Add For InI = .Worksheets.Count To 1 Step -1 ' Anzahl Register in ThisWorkbook Sheets.Add .Worksheets(InI).Cells.Copy With ActiveWorkbook.ActiveSheet.Cells .PasteSpecial Paste:=xlPasteValues ' Werte .PasteSpecial Paste:=xlFormats ' Formate End With ActiveWorkbook.ActiveSheet.Name = .Worksheets(InI).Name Next InI Application.CutCopyMode = False 'Zwischenspeicher löschen Application.DisplayAlerts = False Worksheets(ActiveWorkbook.Worksheets.Count).Delete Application.DisplayAlerts = True MsgBox "Reine Datentabelle gespeichert als: " & .Path & "\Kopie_von" & ThisWorkbook.Name ActiveWorkbook.Close True End With End Sub

ID : 2081
ISLEM : tarihli ve saatli yedek alma
MAKRO KODU : Sub DateiUnter TagesdatumAbspeichern() Tagesdatum = Application.Text(Now(), "mm-dd-yy hh-mm") Sicherung = "Backup" & Tagesdatum & ".XLS" ActiveWorkbook.SaveCopyAs Sicherung End Sub

ID : 2082
ISLEM : tarihli yedek almak 1
MAKRO KODU : Sub tarihli_yedek_al() Dim dname As String, strTest As String dname = "C:\DATA\kubilay.xls" & Format(Now(), "yyyy_mmdd") strTest = Dir(dname, vbDirectory) If (strTest = "") Then MkDir (dname) ActiveWorkbook.SaveCopyAs dname & "\BK_" & Range("A1") & Range("a2") ActiveWorkbook.Save End Sub

ID : 2083
ISLEM : tarihli yedek almak 2
MAKRO KODU : Sub tarihli_yedek_al() Dim dname As String, strTest As String dname = "C:\DATA\" & Range("A1") & " " & Range("a2") & Format(Now(), "yyyy_mmdd") strTest = Dir(dname, vbDirectory) If (strTest = "") Then MkDir (dname) ActiveWorkbook.SaveCopyAs dname & "\BK_" & Range("A1") & Range("a2") ActiveWorkbook.Save End Sub

ID : 2084
ISLEM : tarihten gün çıkarma
MAKRO KODU : Private sub Commandbutton1_click() TextBox9 = Format(DateAdd("d", -TextBox4, ComboBox6), "dd.mm.yyyy") end sub

ID : 2085
ISLEM : tek bir userform ile işlem yapmak
MAKRO KODU : Sub kayıt() UserForm1.OptionButton1.Visible = False UserForm1.OptionButton2.Visible = False UserForm1.Show End Sub

ID : 2086
ISLEM : tek buton ile belirli hücreleri temizleme
MAKRO KODU : Sub temizle() For t = 1 To Sheets.Count Sheets(t).Select For Each hucre In [a1:e20] If hucre.Interior.Color = vbYellow Then hucre.ClearContents Next Next End Sub

ID : 2087
ISLEM : tek hücrede yer alan "ad soyad" bilgisini ayrı hücrelere alma
MAKRO KODU : B1 hücresine aşağıdaki formülü girin: =SOLDAN(YERİNEKOY(A1;" ";"*";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;" ";"")));BUL("*";YERİNEKOY(A1;" ";"*";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;" ";"")));1)-1) Bu formül ile A1 hücresindeki ismin "Adı" kısmını B1 hücresine almış bulunmaktayız. Formülün bu kadar uzun olmasına neden olan ise bazı adların 2 isimden oluşabilmesidir. A1 hücresine "Mehmet Ali Ceylan" yazdığınızda B1 hücresinde "Mehmet Ali" yazıldığını görebilirsiniz. Soyadlarını ayırmak için de C1 hücresine aşağıdaki formülü girin: =PARÇAAL(A1;UZUNLUK(B1)+2;UZUNLUK(A1)-UZUNLUK(B1)) B1 ve C1 hücresindeki formülleri listeniz uzunluğunca kopyaladığında listenizdeki bütün kayıtlar "Adı" ve "Soyadı" halinde 2 farklı sütuna kopyalanmış olacaktır.

ID : 2088
ISLEM : tek tıklamayla çıktı almak
MAKRO KODU : Sub yaz() For a=1 To 22 [j7]=a ActiveSheet.PrintOut Next End Sub

ID : 2089
ISLEM : tek tıklamayla sayfa2'ye git
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$C$18" Then Sheets("Sayfa2").Select End Sub

ID : 2090
ISLEM : temizleme penceresi
MAKRO KODU : Sub Dialog_11() Application.Dialogs(xlDialogClear).Show End Sub

ID : 2091
ISLEM : tersten yazdırma
MAKRO KODU : Sub ReverseText() Dim strText As String, strReverseText As String Dim intPos As Integer, intLen As Integer strText = Selection.Text intLen = Len(strText) For intPos = 1 To Len(strText) strReverseText = strReverseText & Mid(strText, intLen - intPos + 1, 1) Next intPos ActiveCell.FormulaR1C1 = strReverseText End Sub

ID : 2092
ISLEM : texboox1 e bu günün tarihini atmasini istiyorum
MAKRO KODU : Private Sub UserForm_Initialize() TextBox1 = Format(Date, "mm.dd.yyyy") End Sub saat içinde; Private Sub UserForm_Initialize() TextBox1 = Format(Time, "hh:mm") End Sub

ID : 2093
ISLEM : texbox la veri arama
MAKRO KODU : A stununda isimler var Formuma eklediğim textbox kutusunun adı "isim" ve o ismi listeden bulmak istiyorum.. --------------------- Dim bak As Range For Each bak In Range("A1:A" & WorksheetFunction.CountA(Worksheets("sayfa1").Range("A1:A10000"))) If StrConv(bak.Value, vbUpperCase) = StrConv(isim.Value, vbUpperCase) Then bak.Select msgbox("Aradığınız " & ActiveCell.Offset(0, 0).Value & "isim bulundu. Hücre adresi" & ActiveCell.Offset(0, 0).address) ----------------- mesaj kutusunda aradığınız ismi ve adresini görüntüler.

ID : 2094
ISLEM : texboxta yazı rengi
MAKRO KODU : TextBox1.ForeColor = vbRed

ID : 2095
ISLEM : text box biçimlendirme
MAKRO KODU : Private Sub TextBox1_Change() If Len(TextBox1.Text) >= 15 Then TextBox1 = Left(TextBox1, 15) If Len(TextBox1.Text) < 10 Then TextBox1 = Replace(TextBox1, " ", "") Else TextBox1.Text = Format(TextBox1, "(###) ### ## ##") End If End Sub

ID : 2096
ISLEM : text dosyası1) oluşturma
MAKRO KODU : Dosya isminden sonra False yazarsak eski bilgilerin üstüne yazılmaz ve “File Already Exists” yani “Dosya Zaten Var” uyarısı gelir. True yazarsak,eski bilgiler silinir,yenileri yazılır. Bu örnekte bilgi yazma kısmına yer vermedik. Bilgi yazma kısmı makalemizin ikinci kısmında,Alt FSO bölümünde bulunmaktadır. İkinci kısım False olursa dosya ASCII,True olursa UNICODE olur. Sub Text_Dosyası_Oluştur() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") Set a = ds.CreateTextFile("C:\SXS\Deneme.txt", True, False) 'İlk true Overwrite,İkinci False ASCII true olursa Unicode End Sub

ID : 2097
ISLEM : text dosyası2) silme
MAKRO KODU : Dosya silmeye yarar.Dosya isminden sonra gelen yere ,dosya Salt okunursa True yazmalısınız.Yoksa "Access Denied" yani "Giriş Reddedildi" der. Sub Dosya_Sil() Dim ds Set ds = CreateObject("Scripting.FileSystemObject") ds.DeleteFile "C:\SXS\Deneme.txt", True End Sub

ID : 2098
ISLEM : text dosyası3) açma ve hazırlama
MAKRO KODU : Sub Text_Dosyası_Aç() Const ForReading = 1, ForWriting = 2, ForAppending = 3 'For Reading Sadece Okur,For Appending ise hem Okur hem Yazar Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.OpenTextFile("c:\testfile.txt", ForAppending, TristateFalse) 'TristateUseDefault'da System Default,TristateTrue 'da Unicode,TristateFalse'da ASCII kullanılır. End Sub

ID : 2099
ISLEM : text dosyası4) oluştur ve yaz
MAKRO KODU : Sub Text_Dosyası_Oluştur_Yaz() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") Set a = ds.CreateTextFile("C:\Deneme.txt", True, False) 'İlk true Overwrite,İkinci False ASCII true olursa Unicode a.WriteLine ("İlk Satır") a.Close End Sub

ID : 2100
ISLEM : text dosyasından veri alma (alt alta, tüm veriler)
MAKRO KODU : Sub Import() Open "d:\data.txt" For Input As #1 R = 1 While Not EOF(1) 'Scan file line by line C = 1 Entry = "" Line Input #1, Buffer Length = Len(Buffer) i = 1 While i <= Length 'split comma-delimited string into cells If (Mid(Buffer, i, 1)) = "," Then With Application.Cells(R, C) .NumberFormat = "@" 'Text formatting .Value = Entry End With C = C + 1 Entry = "" Else Entry = Entry + Mid(Buffer, i, 1) End If i = i + 1 Wend If Len(Entry) > 0 Then With Application.Cells(R, C) .NumberFormat = "@" 'Text formatting .Value = Entry End With End If R = R + 1 Wend Close #1 End Sub