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


yazdirma alani belli ama sadece içi dolu olan hücrelerin içini nasil yazdirabilirim.

ID : 2491
ISLEM : yazdirma alani belli ama sadece içi dolu olan hücrelerin içini nasil yazdirabilirim.
MAKRO KODU : Sub yazdir() ActiveSheet.PageSetup.PrintArea = "$A$2:$C$" & [a65536].End(3).Row ActiveSheet.PrintOut End Sub

yazdirma alani seçip yazdirmak.

ID : 2492
ISLEM : yazdirma alani seçip yazdirmak.
MAKRO KODU : ActiveSheet.PageSetup.PrintArea = "$B$1:$F$50" ActiveSheet.PrintOut Copies:=1

yazı tipi kalınlığını ayarlama

ID : 2493
ISLEM : yazı tipi kalınlığını ayarlama
MAKRO KODU : Sub FormatRange() Workbooks("Kitap1").Sheets("Sayfa1").Range("A1:D5") _ .Font.Bold = True End Sub

yazıcı penceresi

ID : 2494
ISLEM : yazıcı penceresi
MAKRO KODU : Sub ChangePrinter() Application.Dialogs(xlDialogPrinterSetup).Show End Sub

yazıcı test etme

ID : 2495
ISLEM : yazıcı test etme
MAKRO KODU : Sub LanceTestImp() ValRetour = Shell("C:\WINDOWS\RUNDLL32.EXE msprint2.dll,RUNDLL_PrintTestPage", 1) End Sub

yazıcıdan çıktı alma kopya sayısını siz belirleyin

ID : 2496
ISLEM : yazıcıdan çıktı alma kopya sayısını siz belirleyin
MAKRO KODU : Sub PrintOnePage() Dim wshTemp As Worksheet, wsh As Worksheet Dim rngArr() As Range, c As Range Dim i As Integer Dim j As Integer ReDim rngArr(1 To 1) For Each wsh In ActiveWorkbook.Worksheets i = i + 1 If i > 1 Then ' resize array ReDim Preserve rngArr(1 To i) End If On Error Resume Next Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell) If Err = 0 Then On Error GoTo 0 'Prevent empty rows Do While Application.CountA(c.EntireRow) = 0 _ And c.EntireRow.Row > 1 Set c = c.Offset(-1, 0) Loop Set rngArr(i) = wsh.Range(wsh.Range("A1"), c) End If Next wsh 'Add temp.Worksheet Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count)) On Error Resume Next With wshTemp For i = 1 To UBound(rngArr) If i = 1 Then Set c = .Range("A1") Else Set c = _ ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell) Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row End If 'Copy-paste range (prevent empty range) If Application.CountA(rngArr(i)) > 0 Then rngArr(i).Copy c End If Next i End With On Error GoTo 0 Application.CutCopyMode = False ' prevent marquies With ActiveSheet.PageSetup ' Fit to 1 page .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With 'Preview New Sheet ActiveWindow.SelectedSheets.PrintPreview 'Print Desired Number of Copies i = InputBox("Print how many copies?", "ExcelTips", 1) If IsNumeric(i) Then If i > 0 Then ActiveSheet.PrintOut Copies:=i End If End If 'Delete temp.Worksheet? If MsgBox("Delete the temporary worksheet?", _ vbYesNo, "ExcelTips") = vbYes Then Application.DisplayAlerts = False wshTemp.Delete Application.DisplayAlerts = True End If End Sub

yazıcınızın markasını a1 hücresine yazdır. (api)

ID : 2497
ISLEM : yazıcınızın markasını a1 hücresine yazdır. (api)
MAKRO KODU : Private Declare Function EnumPrintersA Lib "Winspool.drv" _ (ByVal Flags As Long, ByVal name As String, ByVal Level As Long, _ pPrinterEnum As Long, ByVal cdBuf As Long, _ pcbNeeded As Long, pcReturned As Long) As Long Private Declare Function lstrlenA Li

yazım denetimi türkçe, matematik terimleri

ID : 2498
ISLEM : yazım denetimi türkçe, matematik terimleri
MAKRO KODU : Option Explicit Sub AutoCorrectRead() Dim oList As Variant, i As Integer With Application.AutoCorrect oList = .ReplacementList For i = 1 To UBound(oList) Cells(i, 1) = oList(i, 1) Cells(i, 2) = oList(i, 2) Next i End With End Sub Sub AutoCorrectWrite() Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("G20").Select Dim i As Integer With Application.AutoCorrect For i = 1 To Range("a1").CurrentRegion.Rows.Count .AddReplacement Cells(i, 1), Cells(i, 2) Next i End With End Sub

yazım denetimindeki kelimelerin listesi

ID : 2499
ISLEM : yazım denetimindeki kelimelerin listesi
MAKRO KODU : Option Explicit 'Mahmut Bayram 2005 Sub AutoCorrectRead() 'zum Auslesen, danach Tabelle zum Zielrechner Dim oList As Variant, i As Integer With Application.AutoCorrect oList = .ReplacementList For i = 1 To UBound(oList) Cells(i, 1) = oList(i, 1) Cells(i, 2) = oList(i, 2) Next i End With End Sub

yazi animasyonu

ID : 2500
ISLEM : yazi animasyonu
MAKRO KODU : WORD ARD YAZILARINA HAREKET VERİR Sub Animasyon3() ActiveSheet.Shapes("WordArt 3").Select m = 20 For i = 1 To m Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapeCurveUp Next i For i = 1 To m Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapeCurveDown Next i Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapePlainText Range("a1").Select End Sub

yazi tipleri penceresi

ID : 2501
ISLEM : yazi tipleri penceresi
MAKRO KODU : Sub Dialog_29() Application.Dialogs(xlDialogFont).Show End Sub Sub Dialog_31() Application.Dialogs(xlDialogFormatFont).Show End Sub

yazi tiplerini örnekli listele

ID : 2502
ISLEM : yazi tiplerini örnekli listele
MAKRO KODU : Sub yazitipleri() Dim SchrNr As Integer, Schriftliste As Object, Text As Variant Set Schriftliste = Application.CommandBars("formatting").FindControl(Id:=1728) Application.ScreenUpdating = False On Error Resume Next [A:D].ClearContents For SchrNr = 0 To Schriftliste.ListCount - 1 Cells(SchrNr + 1, 1).Value = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 2).Value = "€" 'Eurosymbol Cells(SchrNr + 1, 3).Value = "abcdefghijklmnopqrstuvwxyzäöü" Cells(SchrNr + 1, 4).Value = "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ" Cells(SchrNr + 1, 2).Font.Name = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 3).Font.Name = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 4).Font.Name = Schriftliste.List(SchrNr + 1) Next [A:D].EntireColumn.AutoFit Application.ScreenUpdating = True ' Warnmeldung zuviele Schriften hier einstellbar: If SchrNr > 200 Then Text = Chr(13) & Chr(13) & "Achtung!" & Chr(13) & _ "Sie haben viel zu viele Schriftarten installiert" End If MsgBox " Es wurden insgesamt " & SchrNr & " Schriftarten gefunden." _ & Chr(13) & "Im Feld mit der Roten Schrift sieht man das Eurosymbol," _ & Chr(13) & " wenn die Schrift Eurofähig ist," _ & Chr(13) & " sonst nur ein Kästchen" & Text End Sub

yazilar içerisinde kirmizi renk var ise bulabilirmiyiz?

ID : 2503
ISLEM : yazilar içerisinde kirmizi renk var ise bulabilirmiyiz?
MAKRO KODU : Sub Kırmızıbul() For X = 1 To [A65536].End(3).Row For Y = 1 To Len(Cells(X, 1)) If Cells(X, 1).Characters(Start:=Y, Length:=Y).Font.ColorIndex = 3 Then Cells(X, 2).Value = "Kırmızı" End If Next Next End Sub

yazilari yanip söndürme

ID : 2504
ISLEM : yazilari yanip söndürme
MAKRO KODU : BU KOD VERİLEN ADRESTEKİ YAZILARI YANIP SÖNDÜRÜR Sub FlashFont() Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed Set myCell = Range("A1:D1") Application.DisplayStatusBar = True Application.StatusBar = "... Şu an flash yazı gösterisi var lütfen biraz bekleyin...! " newColor = 4 'yeşil fSpeed = 0.3 Do Until x = 15 'süre 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

yedek alma ile ilgili

ID : 2505
ISLEM : yedek alma ile ilgili
MAKRO KODU : Private Sub CommandButton3_Click() Dim dsy dsy = InputBox("Lütfen LEAD TIME'a ait ayın adını giriniz?", "Lead Time Dosyası Oluşturma", Format(Now, "mmmm_yyyy")) If dsy = Cancel Then Exit Sub On Error GoTo 10 MkDir "C:\LEAD TİME\" & dsy Set NewBook = Workbooks.Add With NewBook .SaveAs "C:\LEAD TİME\" & dsy & "\" & "Lead_time_" & dsy & ".xls" End With Windows("LEAD TİME.xls").Activate Cells.Select Selection.Copy Windows("Lead_time_" & dsy & ".xls").Activate ActiveSheet.Paste Range("A2").Select Range("Z1:AG9").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range("A2").Select ActiveWorkbook.Save ActiveWorkbook.Close Windows("LEAD TİME.xls").Activate Range("A2").Select ActiveWorkbook.Save Unload UserForm1 Exit Sub 10: MsgBox "Dosya ismini kontrol edip tekrar deneyiniz.", vbExclamation, "UYARI!!!!!!!" End Sub

yedek alma şifreleyerek

ID : 2506
ISLEM : yedek alma şifreleyerek
MAKRO KODU : Sub Datensicherung() Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:="C:\Datensicherung.xls", _ FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False Application.DisplayAlerts = True End Sub

yedek alma tarihli

ID : 2507
ISLEM : yedek alma tarihli
MAKRO KODU : Sub date_backup() zaman = Application.Text(Now(), "mm-dd-yy hh-mm") isim = "Yedek" & zaman & ".XLS" ActiveWorkbook.SaveCopyAs isim End Sub

yeni araç çubuğu ekleme

ID : 2508
ISLEM : yeni araç çubuğu ekleme
MAKRO KODU : Sub NeueSymbolleiste() Dim cmdB As CommandBar Set cmdB = CommandBars.Add("MyToolbar", temporary:=True) With cmdB .Left = 50 .Top = 100 .Visible = True End With End Sub

yeni belge açma penceresi

ID : 2509
ISLEM : yeni belge açma penceresi
MAKRO KODU : Sub Dialog_43() Application.Dialogs(xlDialogNew).Show End Sub

yeni belge aöma penceresi

ID : 2510
ISLEM : yeni belge aöma penceresi
MAKRO KODU : Sub Dialog_45() Application.Dialogs(xlDialogOpen).Show End Sub

yeni bir sayfa oluşturmak ve o sayfaya isim vermek.

ID : 2511
ISLEM : yeni bir sayfa oluşturmak ve o sayfaya isim vermek.
MAKRO KODU : Sub Sayfa_Ekle() ThisWorkbook.Sheets.Add Sheets(ActiveSheet.Name).Name =sheets("sayfa1"). [a1].value End Sub

yeni çalişma sayfasi açarken biçimli sayfayi kopyalama

ID : 2512
ISLEM : yeni çalişma sayfasi açarken biçimli sayfayi kopyalama
MAKRO KODU : Kopyalama için aşağıdaki kodu deneyin. visual basic kodu: -------------------------------------------------------------------------------- Sub kopyala() Sheets("Sayfa1").Copy After:=Workbooks("Kitap1").Sheets(1) End Sub

yeni kitap açar

ID : 2513
ISLEM : yeni kitap açar
MAKRO KODU : Sub CreateWindow() Dim wnParent As Window Dim wnChild As Window 'make a reference to be used later Set wnParent = ActiveWindow 'create a new window that will be the smaller window wnParent.NewWindow Set wnChild = ActiveWindow 'change the size of the windows With Application wnChild.WindowState = xlNormal wnChild.Top = .Top + (.Height * 0.2) wnChild.Height = .Height * 0.4 wnChild.Left = .Left + .Width * 0.6 wnChild.Width = .Width * 0.35 wnParent.Top = 1 wnParent.Left = 1 wnParent.Height = .Height * 0.85 wnParent.Width = .Width * 0.95 End With End Sub

yeni kitap oluşturma kitabın ismiyle başlayan ve birer artan kitap oluşturur

ID : 2514
ISLEM : yeni kitap oluşturma kitabın ismiyle başlayan ve birer artan kitap oluşturur
MAKRO KODU : Private Sub Workbook_NewSheet(ByVal Sh As Object) Sh.Move After:=Sheets(Sheets.Count) End Sub

yeni tl ve kuruşa çevir

ID : 2515
ISLEM : yeni tl ve kuruşa çevir
MAKRO KODU : Public Function ParaCevir(Para) Dim ParaStr As String Dim Lira As String, Kurus As String If Not IsNumeric(Para) Then GoTo SayiDegil ParaStr = Format(Abs(Para), "0.00") Lira = Left(ParaStr, Len(ParaStr) - 3) Kurus = Right(ParaStr, 2) ParaCevir = IIf(Para "" Then e = e + Binler(i) If (i = 3) And (e = "birbin") Then e = "bin" Sonuc = Sonuc + e Next i If Sonuc = "" Then Sonuc = "Sıfır" Cevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1) End Function -

yeni web sorgusu alma penceresi

ID : 2516
ISLEM : yeni web sorgusu alma penceresi
MAKRO KODU : Sub Dialog_44() Application.Dialogs(xlDialogNewWebQuery).Show End Sub

yer tanımlama makrosu

ID : 2517
ISLEM : yer tanımlama makrosu
MAKRO KODU : Sub ilan() yer = Worksheets("OkBil").Range("j5").Value 'yer tanımlama sihirbazı OkBil sayfasında seç j5 hücresini seç MsgBox " Sayın " & yer & " pirs@1.00 Programına Hoş Geldiniz!" 'mesaj ver Başına Sayın koy birleştir(&) tanımlı yer ile birleştir(&) evrağınız gelen-giden evrak defterine kayıt edilmiştir. End Sub

yerini değiştirene aşkolsun. (hareket ettirilemeyen userform)

ID : 2518
ISLEM : yerini değiştirene aşkolsun. (hareket ettirilemeyen userform)
MAKRO KODU : Private Sub UserForm_Layout() ' Von Bert Körn ' http://www.forum.excelabc.de/ Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub

yıl ekleme

ID : 2519
ISLEM : yıl ekleme
MAKRO KODU : A1'de tarih B1'de kaç yıl ekleneceği olmalı Sub PratikVB1() MsgBox Format(Day([A1]), "00") & "." & Format(Month([A1]), "00") & "." & Year([A1]) + [B1] End Sub Sub PratikVB2() MsgBox Day([A1]) & "." & Month([A1]) & "." & Year([A1]) + [B1] End Sub

yıldızlı efektler

ID : 2520
ISLEM : yıldızlı efektler
MAKRO KODU : Sub ShowStars() Cells.Select Selection.Interior.ColorIndex = 1 Range("A1").Select Randomize StarWidth = 35 StarHeight = 35 For i = 1 To 10 TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight) LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth) Set NewStar = ActiveSheet.Shapes.AddShape _ (msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight) NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56) Application.Wait Now + TimeValue("00:00:01") DoEvents Next i Application.Wait Now + TimeValue("00:00:02") Set myShapes = Worksheets(1).Shapes For Each shp In myShapes If Left(shp.Name, 9) = "AutoShape" Then shp.Delete Application.Wait Now + TimeValue("00:00:01") End If Next Cells.Select Selection.Interior.ColorIndex = 2 Range("A1").Select End Sub

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