Makro Kod Listesi

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

ID : 1921
ISLEM : sayfayı yatay yapar ve a1 hücresini yazdırır
MAKRO KODU : Sub PrintRpt1() Sheets(1).PageSetup.Orientation = xlLandscape Range("a1").PrintOut Copies:=1 End Sub

ID : 1922
ISLEM : sayfayı yazdırırken çalışma kitabınızın adı ile yazdırır
MAKRO KODU : Sub HeaderName() ActiveSheet.PageSetup.LeftHeader = _ ThisWorkbook.FullName ActiveSheet.PrintPreview End Sub

ID : 1923
ISLEM : sayfayi gizle
MAKRO KODU : Sayfa Gizle Sub auto_open() Worksheets("Sayfa1").Visible = False End Sub

ID : 1924
ISLEM : sayfayi istenilen sayi kadar yazdirma ve numaralandirma
MAKRO KODU : Sub aktifsayfayazdir() Dim Kopyasayısı As Long Dim Kopyanumarası As Long Kopyasayısı = Application.InputBox("Kaç kopya alacaksınız", Type:=1) For Kopyanumarası = 1 To Kopyasayısı ActiveSheet.PrintOut Next Kopyanumarası End Sub

ID : 1925
ISLEM : sayı bulma
MAKRO KODU : Sub NumeroDeLigne() NumeroLigne = Cells.Find("100").Row MsgBox NumeroLigne End Sub

ID : 1926
ISLEM : sayı formatı virgülden sonra 2 basamak
MAKRO KODU : TextBox1.text = format(xxxx,"0.00")

ID : 1927
ISLEM : sayı tutma
MAKRO KODU : Function Uret(Basamak) ReDim Sayi(0 To Basamak) For i = 1 To Basamak YeniSayiTut: Randomize If i = 1 Then Sayi(i) = Int(Rnd * 9) + 1 Else Sayi(i) = Int(Rnd * 10) End If For j = 1 To i - 1 If Sayi(i) = Sayi(j) Then GoTo YeniSayiTut Next j retStr = retStr & Sayi(i) Next i Uret = Val(retStr) End Function

ID : 1928
ISLEM : sayı yaz sonuna ",00" koysun sütun genişliğini ayarlasın, sola yaslasın
MAKRO KODU : Sub MoveMinus() On Error Resume Next Dim cel As Range Dim myVar As Range Set myVar = Selection For Each cel In myVar If Right((Trim(cel)), 1) = "-" Then cel.Value = cel.Value * 1 End If Next With myVar .NumberFormat = "#,##0.00_);[Red](#,##0.00)" .Columns.AutoFit End With End Sub

ID : 1929
ISLEM : sayı yuvarla (matematiksel işlemler)
MAKRO KODU : Kod: [code]Sub bicim() [A2].Value = Abs(1) End Sub[/code] Kod: Sub bicim2() [A2].Value = Atn(1) * 1 End Sub Kod: Sub bicim3() '/- sayıları yuvarla '/- 101 sayısını döndürür [A2].Value = Int(100.9 + 0.5) End Sub Kod: Sub bicim4() '/- sayıları yuvarla '/- 100 sayısını döndürür [A2].Value = Int(100.4 + 0.5) End Sub Kod: Sub bicim5() '/- sayıları yuvarla '/- eksi 101 sayısını döndürür [A2].Value = Int(-100.9 + 0.5) End Sub Kod: Sub bicim6() '/- sayıları yuvarla '/- eksi 100 sayısını döndürür [A2].Value = Int(-100.4 + 0.5) End Sub Kod: Sub bicim7() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 3 sayısını döndürür [A2].Value = Round(3, 49) End Sub Kod: Sub bicim8() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 4 sayısını döndürür [A2].Value = Round(3, 51) End Sub

ID : 1930
ISLEM : sayı yuvarla 1
MAKRO KODU : [code]Sub bicim() [A2].Value = Abs(1) End Sub[/code]

ID : 1931
ISLEM : sayı yuvarla 2
MAKRO KODU : Sub bicim2() [A2].Value = Atn(1) * 1 End Sub

ID : 1932
ISLEM : sayı yuvarla 3
MAKRO KODU : Sub bicim3() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 3 sayısını döndürür [A2].Value = Round(3, 49) End Sub

ID : 1933
ISLEM : sayı yuvarla 4
MAKRO KODU : Sub bicim4() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 4 sayısını döndürür [A2].Value = Round(3, 51) End Sub

ID : 1934
ISLEM : sayıyı dakika ve saniye cinsinden yazma
MAKRO KODU : örnek textbox1=150 'textbox2=2 dakika 30saniye Private Sub CommandButton1_Click() Dim Isec As Integer Isec = Val(TextBox1.Text) BreakSec = Str$(Int(Isec / 60)) & " dakika " & Str$(Isec Mod 60) & " saniye " TextBox2.Text = BreakSec End Sub

ID : 1935
ISLEM : sayıyı dolar olarak okuma =dollartext(a1)
MAKRO KODU : Function DollarText(vNumber) As Variant 'see also Function SpellNumber(ByVal MyNumber), PSS ID Number: Q140704 Dim sDollars As String Dim sCents As String Dim iLen As Integer Dim sTemp As String Dim iPos As Integer Dim iHundreds As Integer Dim iTens As Integer Dim iOnes As Integer Dim sUnits(2 To 5) As String Dim bHit As Boolean Dim vOnes As Variant Dim vTeens As Variant Dim vTens As Variant If Not IsNumeric(vNumber) Then Exit Function End If sDollars = Format(vNumber, "###0.00") iLen = Len(sDollars) - 3 If iLen > 15 Then DollarText = CVErr(xlErrNum) Exit Function End If sCents = Right$(sDollars, 2) & "/100 Dollar" 'Hier die Währung ändern If vNumber < 1 Then DollarText = sCents Exit Function End If sDollars = Left$(sDollars, iLen) vOnes = Array("", "one", "two", "three", "four", "five", _ "six", "seven", "eight", "nine") vTeens = Array("ten", "eleven", "twelve", "thirteen", "fourteen", _ "fifteen", "sixteen", "seventeen", "eighteen", "nineteen") vTens = Array("", "", "twenty", "thirty", "forty", "fifty", _ "sixty", "seventy", "eighty", "ninety") sUnits(2) = "thousand" sUnits(3) = "million" sUnits(4) = "billion" sUnits(5) = "trillion" sTemp = "" For iPos = 15 To 3 Step -3 If iLen >= iPos - 2 Then bHit = False If iLen >= iPos Then iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48 If iHundreds > 0 Then sTemp = sTemp & " " & vOnes(iHundreds) & " hundred" bHit = True End If End If iTens = 0 iOnes = 0 If iLen >= iPos - 1 Then iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48 End If If iLen >= iPos - 2 Then iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48 End If If iTens = 1 Then sTemp = sTemp & " " & vTeens(iOnes) bHit = True Else If iTens >= 2 Then sTemp = sTemp & " " & vTens(iTens) bHit = True End If If iOnes > 0 Then If iTens >= 2 Then sTemp = sTemp & "-" Else sTemp = sTemp & " " End If sTemp = sTemp & vOnes(iOnes) bHit = True End If End If If bHit And iPos > 3 Then sTemp = sTemp & " " & sUnits(iPos \ 3) End If End If Next iPos DollarText = Trim(sTemp) & " and " & sCents End Function 'DollarText

ID : 1936
ISLEM : sayıyı paranteze alma örnek: 3- = (3) sayının yanına çizgi şart
MAKRO KODU : Sub DashMasher() On Error Resume Next Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Set TextCells = Cells.SpecialCells(xlCellTypeConstants, xlTextValues) n = TextCells.Count For Each Cell In TextCells x = Cell.Value If Right(x, 1) = "-" Then x = -Left(x, Len(x) - 1) Cell.Value = x End If c = c + 1 Application.StatusBar = "Percent Complete: " & Int(c / n * 100) & "%" Next Cell Application.StatusBar = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

ID : 1937
ISLEM : sayıyı rakama kuruşlu çevirmek
MAKRO KODU : Function ParaCevir(para As Double) If Not IsNumeric(sayi) Then GoTo hata If (para - Int(para)) = 0 Then paracevir= cevir(para) Else tamsayi = cevir(Int(para)) ondalik = cevir((para - Int(para)) * 100) ondalik = LCase(Mid(ondalik, 1, 1)) + Mid(ondalik, 2, Len(ondalik) - 1) paracevir = tamsayi + "virgül" + ondalik End If GoTo tamam hata: paracevir = "Hata" tamam: End Function Private Function cevir(sayi As Double) Dim b(9) As String Dim y(9) As String Dim m(4) As String Dim v(15) Dim c(3) b(0) = "" b(1) = "bir" b(2) = "iki" b(3) = "üç" b(4) = "dört" b(5) = "beş" b(6) = "altı" b(7) = "yedi" b(8) = "sekiz" b(9) = "dokuz" y(0) = "" y(1) = "on" y(2) = "yirmi" y(3) = "otuz" y(4) = "kırk" y(5) = "elli" y(6) = "altmış" y(7) = "yetmiş" y(8) = "seksen" y(9) = "doksan" m(0) = "trilyon" m(1) = "milyar" m(2) = "milyon" m(3) = "bin" m(4) = "" a = Str(Round(sayi, 0)) If Left(a, 1) = " " Then pozitif = 1 Else pozitif = 0 a = Right(a, Len(a) - 1) If Len(a) > 15 Then GoTo hata a = String(15 - Len(a), "0") + a For x = 1 To 15 v(x) = Val(Mid(a, x, 1)) Next x s = "" For x = 0 To 4 c(1) = v(x * 3 + 1) c(2) = v(x * 3 + 2) c(3) = v(x * 3 + 3) If c(1) = 0 Then e = "" ElseIf c(1) = 1 Then e = "yüz" Else e = b(c(1)) + "yüz" End If e = e + y(c(2)) + b(c(3)) If e <> "" Then e = e + m(x) If (x = 3) And (e = "birbin") Then e = "bin" s = s + e Next x If s = "" Then s = "sıfır" If pozitif = 0 Then s = "eksi" + s cevir = UCase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1) End Function exit sub Hata: cevir="HATA" end function

ID : 1938
ISLEM : sayinin karekökü
MAKRO KODU : İlgili sayıyı sqr() ile karekök olarak dönüştürebilirsiniz. Ã rnek A1 de sayımız olsun; Kod: Sub karekok() sonuc = Sqr(Range("A1").Value) MsgBox (sonuc) End Sub

ID : 1939
ISLEM : seç bir aşağıya sürüklesin
MAKRO KODU : Sub Einfügen() Dim Letzte As Long Dim Zeile As Integer Dim I As Long Letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Zeile = Application.InputBox("Nach wieviel Zeilen Leerzeile einfügen", "Zeilenanzahl", 0, Type:=1) If Zeile = 0 Then Exit Sub For I = Letzte To 2 Step Zeile * -1 Rows(I).Insert Shift:=xlDown Next I End Sub

ID : 1940
ISLEM : seç birleştir ortala
MAKRO KODU : Sub CenterAcrossColumns() With Selection .HorizontalAlignment = xlCenterAcrossSelection .MergeCells = False End With End Sub

ID : 1941
ISLEM : seçilen alanın 2 sayfa olarak yazdırılması
MAKRO KODU : Selection.PrintOut Copies:=2

ID : 1942
ISLEM : seçilen alanın baskı önizlemesi
MAKRO KODU : Sheets("Sayfa1").PageSetup.PrintArea = "$A$1:$k$58" ActiveWindow.SelectedSheets.PrintPreview

ID : 1943
ISLEM : seçilen alanları bir kağıtta yazdırır eder
MAKRO KODU : Çoklu çalışma sayfalarında yazdırma (print) komutu uygulaması... 'Tüm seçili sayfalardan vede seçili alanlardan tek bir sayfanın print yapılması ? Sub MultiSheetPrint() Dim oActive As Object Dim oSheet As Object Dim oSheets As Object Dim wsPrint As Worksheet Dim oLastPic As Object Dim iPics As Integer ' remember where we are Set oSheets = ActiveWindow.SelectedSheets If oSheets.Count = 1 Then Selection.PrintOut preview:=True Exit Sub End If Set oActive = ActiveSheet Application.ScreenUpdating = False oActive.Select ' otherwise we get lots of new sheets Set wsPrint = Worksheets.Add For Each oSheet In oSheets If TypeName(oSheet) = "Worksheet" Then iPics = iPics + 1 oSheet.Activate Selection.CopyPicture wsPrint.Cells(iPics * 3 - 2, 1).Value = oSheet.Name wsPrint.Paste wsPrint.Cells(iPics * 3 - 1, 1) wsPrint.Rows(iPics * 3 - 1).RowHeight = _ wsPrint.Pictures(iPics).Height End If Next wsPrint.PrintOut preview:=True Application.DisplayAlerts = False wsPrint.Delete Application.DisplayAlerts = True oSheets.Select oActive.Activate Application.ScreenUpdating = True End Sub

ID : 1944
ISLEM : seçilen alanlari bir kağitda yazdirir eder
MAKRO KODU : Çoklu çalışma sayfalarında yazdırma (print) komutu uygulaması... 'Tüm seçili sayfalardan vede seçili alanlardan tek bir sayfanın print yapılması ? Sub MultiSheetPrint() Dim oActive As Object Dim oSheet As Object Dim oSheets As Object Dim wsPrint As Worksheet Dim oLastPic As Object Dim iPics As Integer ' remember where we are Set oSheets = ActiveWindow.SelectedSheets If oSheets.Count = 1 Then Selection.PrintOut preview:=True Exit Sub End If Set oActive = ActiveSheet Application.ScreenUpdating = False oActive.Select ' otherwise we get lots of new sheets Set wsPrint = Worksheets.Add For Each oSheet In oSheets If TypeName(oSheet) = "Worksheet" Then iPics = iPics + 1 oSheet.Activate Selection.CopyPicture wsPrint.Cells(iPics * 3 - 2, 1).Value = oSheet.Name wsPrint.Paste wsPrint.Cells(iPics * 3 - 1, 1) wsPrint.Rows(iPics * 3 - 1).RowHeight = _ wsPrint.Pictures(iPics).Height End If Next wsPrint.PrintOut preview:=True Application.DisplayAlerts = False wsPrint.Delete Application.DisplayAlerts = True oSheets.Select oActive.Activate Application.ScreenUpdating = True End Sub

ID : 1945
ISLEM : seçilen dosyanın adını okur
MAKRO KODU : Sub DateinameFiltern() Dim strDName strDName = Application.GetOpenFilename strDName = Dir(strDName) MsgBox strDName End Sub

ID : 1946
ISLEM : seçilen hücre rakamsa 0 yapar harfse yapmaz
MAKRO KODU : Sub ResetValues2() For i = 1 To Worksheets.Count On Error GoTo ErrorHandler For Each n In Worksheets(i).UsedRange If IsNumeric(n) Then If n.Value <> 0 Then n.Value = 0 ProtectedCell: End If End If Next n ErrorHandler: If Err = 1005 Then Resume ProtectedCell End If Next i End Sub

ID : 1947
ISLEM : seçilen hücreler renklenir
MAKRO KODU : Workbook code bölümüne Option Explicit Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldCell As Range If Not OldCell Is Nothing Then OldCell.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub 'Sayfanın code bölümüne Option Explicit 'son aktif olan hücrenin rengi sabit olarak kalıyor. Buna bir çözüm varmı? Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) ActiveCell.Interior.ColorIndex = xlColorIndexNone End Sub

ID : 1948
ISLEM : seçilen hücrelerdeki formülleri değere dönüştürür
MAKRO KODU : Sub formullerideğeryap() For Each fCell In Selection fCell.Value = fCell.Value Next fCell End Sub

ID : 1949
ISLEM : seçilen hücrelerdeki formülleri değere dönüştürür 2
MAKRO KODU : Sub metnecevır() Col = 1 DerLig = Cells(65536, Col).End(xlUp).Row For i = 1 To DerLig Cells(i, Col).Formula = "'" & Cells(i, Col) Cells(i, Col).Formula = "" & Cells(i, Col) Next i End Sub

ID : 1950
ISLEM : seçilen hücrelerdeki sıralı sayıları tersten sıralar
MAKRO KODU : Sub Cevir() For Each hucre In Selection n = n + 1 Next hucre ReDim aralik(n) For Each hucre In Selection aralik(i) = hucre.Value i = i + 1 Next hucre For Each hucre In Selection i = i - 1 hucre.Value = aralik(i) Next hucre End Sub