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


pencereyi dikey bölme 2

ID : 1621
ISLEM : pencereyi dikey bölme 2
MAKRO KODU : Sub GotoCol2() With Application ActiveWindow.FreezePanes = False Range("H1").Select ActiveWindow.FreezePanes = True .Goto Reference:=Range("Z1"), Scroll:=True End With End Sub

performans testi

ID : 1622
ISLEM : performans testi
MAKRO KODU : Sub PerformanceTest() Dim i As Long Dim lngStart As Long lngStart = Timer With Workbooks(1).Sheets(1) For i = 1 To 65536 .Cells(i, 1).Value = "Selamün Aleyküm!" Next i End With MsgBox (Timer - lngStart) & " saniye" End Sub Sub performanstesti() Dim i As Long Dim lngStart As Long lngStart = Timer For i = 1 To 65536 ActiveWorkbook.Sheets(1).Cells(i, 1).Value = "Mahmut BAYRAM" Next i MsgBox (Timer - lngStart) & " Saniye Vay be!" End Sub Sub PerformanceTest() Dim i As Long Dim lngStart As Long Dim rngZellen As Range lngStart = Timer Set rngZellen = Workbooks(1).Sheets(1).Cells For i = 1 To 65536 rngZellen(i, 1).Value = "Hello World!" Next i MsgBox (Timer - lngStart) & " Sekunden" End Sub Sub PerformanceTest() Dim i As Long Dim lngStart As Long Dim rngZellen As Range lngStart = Timer Set rngZellen = Workbooks(1).Sheets(1).Range("A1:A65536").Rows rngZellen.Value = "Hello World!" MsgBox (Timer - lngStart) & " Sekunden" End Sub

peşpeşe bul komutu

ID : 1623
ISLEM : peşpeşe bul komutu
MAKRO KODU : Global siparisler, sevkiyat, hammadde, emirler, kitap As Workbook Global rng, kosul As Range Global adres As String Function toplam(sht As Worksheet, malzeme As String, sart As String) Set rng = sht.Range("C3:C5000").Find(malzeme, Lookat:=xlWhole) Do If rng.Offset(0, 1) = sart Then toplam = toplam + rng.Offset(0, 2) Set rng = sht.Range(rng, Range("C5000")).FindNext If rng.Address = adres Then Exit Do adres = rng.Address Loop Set rng = Nothing End Function Sub güncelle() Dim ara As String Set kosul = Range(InputBox("Güncellenecek tarihin hücre adresini girin")) Application.ScreenUpdating = False ara = ActiveSheet.Name Set kitap = ThisWorkbook Set siparisler = Workbooks.Open("G:\Deneme\Sipariş.xls") Set sevkiyat = Workbooks.Open("G:\Deneme\Sevkiyat.xls") Set hammadde = Workbooks.Open("G:\Deneme\Hammadde.xls") Set emirler = Workbooks.Open("G:\Deneme\Emirler.xls") siparisler.Activate kosul.Offset(0, 1) = toplam(siparisler.Sheets("Günlük"), ara, kosul.Value) hammadde.Activate kosul.Offset(0, 2) = toplam(hammadde.Sheets("Günlük"), ara, kosul.Value) sevkiyat.Activate kosul.Offset(0, 3) = toplam(sevkiyat.Sheets("Günlük"), ara, kosul.Value) emirler.Activate kosul.Offset(0, 4) = toplam(emirler.Sheets("Günlük"), ara, kosul.Value) siparisler.Close False hammadde.Close False sevkiyat.Close False emirler.Close False kitap.Activate End Sub

pivot table sum - count hakkinda

ID : 1624
ISLEM : pivot table sum - count hakkinda
MAKRO KODU : Sub Makro2() Dim tablo As PivotTable Dim alan As PivotField For Each tablo In ActiveSheet.PivotTables For Each alan In tablo.DataFields alan.Function = xlCount Next Next End Sub

pivot table verileri yineleme

ID : 1625
ISLEM : pivot table verileri yineleme
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) ActiveSheet.PivotTables("PivotTable4").RefreshTable End Sub

pivot table yenileme

ID : 1626
ISLEM : pivot table yenileme
MAKRO KODU : Sub Refresh_Pivot() ActiveSheet.PivotTables("PivotTable").PivotSelect "b", xlDataAndLabel ActiveSheet.PivotTables("PivotTable").RefreshTable End Sub

pivot tables veri yineleme

ID : 1627
ISLEM : pivot tables veri yineleme
MAKRO KODU : ActiveSheet.PivotTables("PivotTable").RefreshTable

pivot tablo bilgilerinin güncellenmesinin açık olduğunu bildirir

ID : 1628
ISLEM : pivot tablo bilgilerinin güncellenmesinin açık olduğunu bildirir
MAKRO KODU : Private Sub ConnectionApp_PivotTableOpenConnection(ByVal Target As PivotTable) MsgBox "The PivotTable connection has been opened." End Sub

pivot tablo bilgilerinin güncellenmesinin kapalı olduğunu bildirir

ID : 1629
ISLEM : pivot tablo bilgilerinin güncellenmesinin kapalı olduğunu bildirir
MAKRO KODU : Private Sub ConnectionApp_PivotTableCloseConnection(ByVal Target As PivotTable) MsgBox "The PivotTable connection has been closed." End Sub

pivot tablodaki bilgileri yenileme 1

ID : 1630
ISLEM : pivot tablodaki bilgileri yenileme 1
MAKRO KODU : Sub RefreshAllPivots() Dim wks As Worksheet Dim pt As PivotTable For Each wks In Worksheets For Each pt In wks.PivotTables pt.RefreshTable Next pt Next wks End Sub

pivot tablodaki bilgileri yenileme 2

ID : 1631
ISLEM : pivot tablodaki bilgileri yenileme 2
MAKRO KODU : Sub Refresh_Pivot() ActiveSheet.PivotTables("PivotTable").PivotSelect "b", xlDataAndLabel ActiveSheet.PivotTables("PivotTable").RefreshTable End Sub

print alinmişsa sayiyi bir artir

ID : 1632
ISLEM : print alinmişsa sayiyi bir artir
MAKRO KODU : Sub Düğme1_Tıklat() Range("A1") = Range("A1") + 1 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True Range("A1") = Range("A1") + 1 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True End Sub

program açıldığında merhaba

ID : 1633
ISLEM : program açıldığında merhaba
MAKRO KODU : Sub Auto_Open() Msgbox "Hello" End Sub

program kapar

ID : 1634
ISLEM : program kapar
MAKRO KODU : Sub kapa() MsgBox "Bu programı pir düzenlemiştir.", , "KAPATILIYOR" ActiveWorkbook.Close True End Sub

rakamı metne çevirme

ID : 1635
ISLEM : rakamı metne çevirme
MAKRO KODU : Function yaz$(sayi) Dim b$(9) Dim y$(9) Dim m$(4) Dim v(15) Dim c(3) b$(0) = "" b$(1) = "Bir" b$(2) = "İki" 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(sayi) If Left$(a$, 1) = " " Then pozitif = 1 Else pozitif = 0 a$ = Right$(a$, Len(a$) - 1) For x = 1 To Len(a$) If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) 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$ yaz$ = s$ GoTo tamam hata: yaz$ = "Hata" tamam: End Function -

rakamı metne çevirme 2

ID : 1636
ISLEM : rakamı metne çevirme 2
MAKRO KODU : Yaziyla Fonksiyonu ' Fonksiyonu kullanmak için bu modül dosyasını ' projenize ekleyin ' ' Mesut AKCAN ' http://www.mesut.web.tr ' akcan@mesut.web.tr Function yaziyla(sayi As Currency) As String 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) = "İki" 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(sayi) If Left$(a$, 1) = " " Then pozitif = 1 Else pozitif = 0 a$ = Right$(a$, Len(a$) - 1) For x = 1 To Len(a$) If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) 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$ yaziyla = s$ GoTo tamam hata: yaziyla = "Hata" tamam: End Function -

rakamı yazıya çevirme makrosu

ID : 1637
ISLEM : rakamı yazıya çevirme makrosu
MAKRO KODU : Function yaziyacevir(rakam) Dim grup(5), sayi(10, 3), basamak(5), oku(3) sayi(0, 1) = "": sayi(0, 2) = "": sayi(0, 3) = "" sayi(1, 1) = "YÜZ": sayi(1, 2) = "ON": sayi(1, 3) = "BİR" sayi(2, 1) = "İKİYÜZ": sayi(2, 2) = "YİRMİ": sayi(2, 3) = "İKİ" sayi(3, 1) = "ÜÇYÜZ": sayi(3, 2) = "OTUZ": sayi(3, 3) = "ÜÇ" sayi(4, 1) = "DÖRTYÜZ": sayi(4, 2) = "KIRK": sayi(4, 3) = "DÖRT" sayi(5, 1) = "BEŞYÜZ": sayi(5, 2) = "ELLİ": sayi(5, 3) = "BEŞ" sayi(6, 1) = "ALTIYÜZ": sayi(6, 2) = "ALTMIŞ": sayi(6, 3) = "ALTI" sayi(7, 1) = "YEDİYÜZ": sayi(7, 2) = "YETMİŞ": sayi(7, 3) = "YEDİ" sayi(8, 1) = "SEKİZYÜZ": sayi(8, 2) = "SEKSEN": sayi(8, 3) = "SEKİZ" sayi(9, 1) = "DOKUZYÜZ": sayi(9, 2) = "DOKSAN": sayi(9, 3) = "DOKUZ" basamak(5) = "TRİLYON" basamak(4) = "MİLYAR" basamak(3) = "MİLYON" basamak(2) = "BİN" basamak(1) = "" lira = Int(rakam) kurus = Round(rakam - lira, 2) * 100 If Len(lira) > 15 Then MsgBox ("Bu fonksiyon en fazla 15 haneli sayılar için çalışır.") End End If kalan = lira yaziyacevir = "" For x = 1 To 5 a = 15 - 3 * x If Len(lira) > a Then grup(6 - x) = Int(kalan / 10 ^ a) kalan = kalan - (grup(6 - x) * 10 ^ a) End If Next x If grup(5) > 0 Then oku(1) = Int(grup(5) / 100) baskalan = grup(5) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(5) End If If grup(4) > 0 Then oku(1) = Int(grup(4) / 100) baskalan = grup(4) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(4) End If If grup(3) > 0 Then oku(1) = Int(grup(3) / 100) baskalan = grup(3) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(3) End If If grup(2) = 1 Then yaziyacevir = yaziyacevir + "BİN" End If If grup(2) > 1 Then oku(1) = Int(grup(2) / 100) baskalan = grup(2) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(2) End If If grup(1) > 0 Then oku(1) = Int(grup(1) / 100) baskalan = grup(1) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(1) End If yaziyacevir = yaziyacevir + " YTL." If kurus > 0 Then oku(2) = 0 If Len(kurus) > 1 Then oku(2) = Int(kurus / 10) End If oku(3) = kurus - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(2), 2) + sayi(oku(3), 3) + " YKR." End If End Function

rakamı yazıyaçevirmek(ingilizce)

ID : 1638
ISLEM : rakamı yazıyaçevirmek(ingilizce)
MAKRO KODU : ‘Kullanılışı ‘=SpellNumber(A1) yada ‘=SpellNumber(250) şeklinde kullanabilirsini Option Explicit '**************** ' Main Function * '**************** Function SpellNumber(ByVal MyNumber) Dim Dollars, Cents, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Thousand " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " ' String representation of amount MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none DecimalPlace = InStr(MyNumber, ".") 'Convert cents and set MyNumber to dollar amount If DecimalPlace > 0 Then Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber "" Temp = GetHundreds(Right(MyNumber, 3)) If Temp "" Then Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Dollars Case "" Dollars = "No Dollars" Case "One" Dollars = "One Dollar" Case Else Dollars = Dollars & " Dollars" End Select Select Case Cents Case "" Cents = " and No Cents" Case "One" Cents = " and One Cent" Case Else Cents = " and " & Cents & " Cents" End Select SpellNumber = Dollars & Cents End Function '******************************************* ' Converts a number from 100-999 into text * '******************************************* Private Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) 'Convert the hundreds place If Mid(MyNumber, 1, 1) "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred " End If 'Convert the tens and ones place If Mid(MyNumber, 2, 1) "0" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function '********************************************* ' Converts a number from 10 to 99 into text. * '********************************************* Private Function GetTens(TensText) Dim Result As String Result = "" 'null out the temporary function value If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19 Select Case Val(TensText) Case 10: Result = "Ten" Case 11: Result = "Eleven" Case 12: Result = "Twelve" Case 13: Result = "Thirteen" Case 14: Result = "Fourteen" Case 15: Result = "Fifteen" Case 16: Result = "Sixteen" Case 17: Result = "Seventeen" Case 18: Result = "Eighteen" Case 19: Result = "Nineteen" Case Else End Select Else ' If value between 20-99 Select Case Val(Left(TensText, 1)) Case 2: Result = "Twenty " Case 3: Result = "Thirty " Case 4: Result = "Forty " Case 5: Result = "Fifty " Case 6: Result = "Sixty " Case 7: Result = "Seventy " Case 8: Result = "Eighty " Case 9: Result = "Ninety " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) 'Retrieve ones place End If GetTens = Result End Function '******************************************* ' Converts a number from 1 to 9 into text. * '******************************************* Private Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = "One" Case 2: GetDigit = "Two" Case 3: GetDigit = "Three" Case 4: GetDigit = "Four" Case 5: GetDigit = "Five" Case 6: GetDigit = "Six" Case 7: GetDigit = "Seven" Case 8: GetDigit = "Eight" Case 9: GetDigit = "Nine" Case Else: GetDigit = "" End Select End Function -

rakamlarin soluna sifir eklenmesi

ID : 1639
ISLEM : rakamlarin soluna sifir eklenmesi
MAKRO KODU : 148 Nolu Dış Genelge ile ilgilyse çalışman,TextBoxlarda değil Hücrelerde bu işlemi yapmanı tavsiye ederim.İstediğin Kod; Kod: Private Sub TextBox1_Change() TextBox1.Text = Format(TextBox1.Text, "0000") End Sub

raporlamadaki sorun

ID : 1640
ISLEM : raporlamadaki sorun
MAKRO KODU : Private Sub CommandButton1_Click() Dim a As Integer Sheets("liste").Select Columns("a:m").Copy Sheets("raporlama").Select Columns("a").PasteSpecial Application.CutCopyMode = False Sheets("liste").Select For a = 13 To 1 Step -1 If Controls("checkbox" & a).Value = False Then Sheets("raporlama").Columns(a).Delete Next End Sub

rastgele (random) numara verme

ID : 1641
ISLEM : rastgele (random) numara verme
MAKRO KODU : Sub RandomNumbers() Dim Number() Dim MyRange As Range Dim c As Range Set MyRange = Selection LastNumber = 100000 ReDim Number(LastNumber) For i = 1 To LastNumber Number(i) = i Next i For Each c In MyRange Placement = Int(Rnd() * LastNumber + 1) c.Value = Number(Placement) dummy = Number(LastNumber) Number(LastNumber) = Number(Placement) Number(Placement) = dummy LastNumber = LastNumber - 1 Next c End Sub

rastgele bir sayinin üretilmesi

ID : 1642
ISLEM : rastgele bir sayinin üretilmesi
MAKRO KODU : Sub Kura_Sonuc() For i = 1 To 15 'Kuraya Katılacak Kişi sayısı Randomize MsgBox Int(Rnd(1) * 100) 'Kuraya Katılacak Kişi Sayısı Next End Sub

rastgele sayı üretir 49 dan küçük

ID : 1643
ISLEM : rastgele sayı üretir 49 dan küçük
MAKRO KODU : Sub RandomNo() Randomize MyNumber = Int((49 - 1 + 1) * Rnd + 1) MsgBox ("The random number is ") & (MyNumber) End Sub

rastgele sayı üretme

ID : 1644
ISLEM : rastgele sayı üretme
MAKRO KODU : Sub Aleatoire() Dim NbreAlea As Integer Randomize NbreAlea = Int((10 * Rnd) + 1) Range("A1") = NbreAlea End Sub

rastgele sayı üretmek

ID : 1645
ISLEM : rastgele sayı üretmek
MAKRO KODU : Evvvel D1 hücresine üretmek istediğiniz rakamların üst sınırını yazınız. D2 hücresine ise kaç adet sayı üreteceğinizi yazınız. Sub rastgele() Dim i As Integer Dim bul As Range Randomize If Range("D1").Value -

rastgele sayı üretmek

ID : 1646
ISLEM : rastgele sayı üretmek
MAKRO KODU : Sub DEN() Dim MyValue MyValue = Int((6 * Rnd) + 1) MsgBox MyValue End Sub

rastgele sayı üretmek 2

ID : 1647
ISLEM : rastgele sayı üretmek 2
MAKRO KODU : Sub Kura_Sonuc() For i = 1 To 15 'Kuraya Katılacak Kişi sayısı Randomize MsgBox Int(Rnd(1) * 100) 'Kuraya Katılacak Kişi Sayısı Next End Sub

rastgele sayılar üreten random

ID : 1648
ISLEM : rastgele sayılar üreten random
MAKRO KODU : Sub RandomNumbers() Dim Number() Dim MyRange As Range Dim c As Range Set MyRange = Selection LastNumber = 100000 ReDim Number(LastNumber) For i = 1 To LastNumber Number(i) = i Next i For Each c In MyRange Placement = Int(Rnd() * LastNumber + 1) c.Value = Number(Placement) dummy = Number(LastNumber) Number(LastNumber) = Number(Placement) Number(Placement) = dummy LastNumber = LastNumber - 1 Next c End Sub

rastgele seçer fakat seçtiğini bir daha seçmez

ID : 1649
ISLEM : rastgele seçer fakat seçtiğini bir daha seçmez
MAKRO KODU : Sub rast1() Dim rastgele As Integer ilk: rastgele = Int(Rnd() * 11) If rastgele -

rastgele seçimi farklı hücrelerden başlayarak yapar

ID : 1650
ISLEM : rastgele seçimi farklı hücrelerden başlayarak yapar
MAKRO KODU : Sub Random() Dim Satir As Integer Static Say As Integer Static Dizi(1 To 10) If Say = 10 Then Say = 0: Erase Dizi devam: Randomize Satir = Int((Rnd * 10) + 1) If IsError(Application.Match(Satir, Dizi(), 0)) And Say -

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