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


her 30 sn de bir mesaj verme (makro)

ID : 991
ISLEM : her 30 sn de bir mesaj verme (makro)
MAKRO KODU : Modüle Option Explicit Sub MsgBox_alle_5min() Dim NextTime As Date NextTime = Now + TimeValue("00:00:30") Application.OnTime NextTime, "AufrufMsgBox" End Sub Sub AufrufMsgBox() MsgBox "Nicht vergessen zu speichern." Call MsgBox_alle_5min End Sub 'Thisworbook a Option Explicit Private Sub Workbook_Open() Call MsgBox_alle_5min End Sub 'Sayfanın kod bölümüne Option Explicit

her 5 dk a1:a3000 arasında veri varsa bir uyarı vermeden silme

ID : 992
ISLEM : her 5 dk a1:a3000 arasında veri varsa bir uyarı vermeden silme
MAKRO KODU : Sub auto_open() Application.OnTime Now + TimeValue("00:05:00"), "dene" End Sub Sub dene() on error resume next Range("A1:A3000").SpecialCells(xlCellTypeConstants ).EntireRow.Delete Call auto_open End Sub

her 5 satırdan sonraki satırın yüksekliği 5

ID : 993
ISLEM : her 5 satırdan sonraki satırın yüksekliği 5
MAKRO KODU : Sub Ligne() Range("D1:D20").Select 'Exemple de sélection possible For Each col In Selection.Rows If col.Row Mod 6 = 0 Then col.RowHeight = 5 End If Next col End Sub

her 5 sn de bir makro çalıştırma (mesaj)

ID : 994
ISLEM : her 5 sn de bir makro çalıştırma (mesaj)
MAKRO KODU : Public bekleme As Double Public Const Pause = 5 '5 saniye Public Const CallMakro = "Selam" Sub StartTimer() bekleme = Now + TimeSerial(0, 0, Pause) Application.OnTime earliesttime:=bekleme, _ procedure:=CallMakro, schedule:=True End Sub Sub Selam() MsgBox ("Selamun Aleyküm") StartTimer End Sub Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=bekleme, _ procedure:=CallMakro, schedule:=False End Sub

her 50 satırda bir toplam alır

ID : 995
ISLEM : her 50 satırda bir toplam alır
MAKRO KODU : Sub Zwischensumme() ' Bildet die Zwischensumme der Spalte C nach jeweils 49 Zeilen, fügt einen Seitenwechsel ein und überträgt die Zwischensumme auf die neue Seite For i = 50 To 2500 Step 50 '2500 ist Zeilenanzahl, ggf ändern a = i + 2 Rows(i).Select Selection.EntireRow.Insert Selection.EntireRow.Insert Cells(i, 3).FormulaR1C1 = "=SUM(R[-49]C:R[-1]C)" '3 steht für Spalte C Cells(i + 1, 3).Value = Cells(i, 3) '3 steht für Spalte C ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 1, 3) '3 steht für Spalte C Next i End Sub

her hangi bir sayfaya hızlı bilgi girşi için

ID : 996
ISLEM : her hangi bir sayfaya hızlı bilgi girşi için
MAKRO KODU : Private Sub cmd_click() Columns("A:D").Select ActiveSheet.ShowDataForm End Sub 'Sayfa içerisindeki başlıklar excel'in kendi form ile birlikte 'size sorulacak , bu sayede pratik bir şekilde veri girişi sağlanabilir.

her saniye arayla mesaj verme

ID : 997
ISLEM : her saniye arayla mesaj verme
MAKRO KODU : Option Explicit Sub Countdown() Dim intCounter As Integer Dim bln As Boolean bln = Application.DisplayStatusBar For intCounter = 10 To 1 Step -1 Application.StatusBar = "Noch " & _ intCounter & " Sekunden ..." Application.Wait Now + TimeSerial(0, 0, 1) Next intCounter Application.StatusBar = False Application.DisplayStatusBar = bln MsgBox "Fertig ", vbOKOnly, "© K.-M. Buss" End Sub

her saniyede bip ile birlite mesaj alma

ID : 998
ISLEM : her saniyede bip ile birlite mesaj alma
MAKRO KODU : Sub bip_uyari() pir = InputBox("Almak istediğinizi mesajı yazınız?") For Count = 1 To pir Beep Application.Wait Now() + TimeValue("00:00:01") Next Count End Sub

her sayfayı ayrı ayrı kitap olarak c'ye kaydetme

ID : 999
ISLEM : her sayfayı ayrı ayrı kitap olarak c'ye kaydetme
MAKRO KODU : Sub BreakItUp() Dim sht As Worksheet Dim NFName As String Const WBPath = "C:\" For Each sht In ActiveWorkbook.Worksheets sht.Copy NFName = WBPath & sht.Name & ".xls" ActiveWorkbook.SaveAs FileName:=NFName, _ FileFormat:=xlNormal, CreateBackup:=False ActiveWindow.Close Next End Sub

her veri girişten sonra mesaj alma

ID : 1000
ISLEM : her veri girişten sonra mesaj alma
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range("B:B")) Is Nothing Then MsgBox "Elemtere fiş kem gözlere şiş!", vbOKOnly, "www.pir38.sitemynet.com" End If End Sub

herhangi bir form üzeründeki metin kutusuna girilecek karakter sayisini nasil sinirlandirabilirim

ID : 1001
ISLEM : herhangi bir form üzeründeki metin kutusuna girilecek karakter sayisini nasil sinirlandirabilirim
MAKRO KODU : aşağıdaki kodları bie denerseniz sanırım istediğiniz olacaktır. Bunları module değilde objelerin kendi kodları olarak girmelisiniz. Kod: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'Girilen değer numerik değilse Textboxten çıkışı engelliyor, bu durumda boşta olamıyor. If IsNumeric(TextBox1.Value) Then Cancel = False Else Cancel = True Beep ' 'beep' sesi üretiyor MsgBox ("Sadece sayı girin!") ' Uyarı penceresi açıyor. End If End Sub Private Sub UserForm_Initialize() TextBox1.MaxLength = 8 End Sub

herhangi bir hücreye tıklayınca makro çalışsın

ID : 1002
ISLEM : herhangi bir hücreye tıklayınca makro çalışsın
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Address = "$H$3" Then test End If End Sub Sub test() MsgBox "aaaaaaaaaaaaaaaaaa" End Sub

herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazar ve haftasonlarını renklendirir

ID : 1003
ISLEM : herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazar ve haftasonlarını renklendirir
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, [A:A]) Is Nothing Then Exit Sub Cancel = True Satır = Target.Row Range(Cells(Satır, 1), Cells(Satır + 1, 31)).ClearContents Range(Cells(Satır, 1), Cells(Satır + 1, 31)).Interior.ColorIndex = xlNone TARİH = DateSerial(Year(Now), Month(Now), 1) AYINİLKGÜNÜ = TARİH AYEKLE = DateAdd("M", 1, TARİH) AYINSONGÜNÜ = DateAdd("D", -1, CDate(AYEKLE)) Sütun = 1 For GÜNLER = AYINİLKGÜNÜ To AYINSONGÜNÜ Cells(Satır, Sütun) = GÜNLER Cells(Satır + 1, Sütun) = Format(GÜNLER, "DDDD") If Weekday(Cells(Satır, Sütun), vbMonday) = 6 Or Weekday(Cells(Satır, Sütun), vbMonday) = 7 Then Range(Cells(Satır, Sütun), Cells(Satır + 1, Sütun)).Interior.ColorIndex = 6 End If Sütun = Sütun + 1 Next End Sub

herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazma

ID : 1004
ISLEM : herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazma
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, [A:A]) Is Nothing Then Exit Sub Cancel = True Satır = Target.Row Range(Cells(Satır, 1), Cells(Satır + 1, 31)).ClearContents TARİH = DateSerial(Year(Now), Month(Now), 1) AYINİLKGÜNÜ = TARİH AYEKLE = DateAdd("M", 1, TARİH) AYINSONGÜNÜ = DateAdd("D", -1, CDate(AYEKLE)) Sütun = 1 For GÜNLER = AYINİLKGÜNÜ To AYINSONGÜNÜ Cells(Satır, Sütun) = GÜNLER Cells(Satır + 1, Sütun) = Format(GÜNLER, "DDDD") Sütun = Sütun + 1 Next End Sub

herhangi bir tarihten sonraki ilk pazartesiyi bulma

ID : 1005
ISLEM : herhangi bir tarihten sonraki ilk pazartesiyi bulma
MAKRO KODU : =G1+8-weekday(G1;2) '=G1+8-HAFTANINGÜNÜ(G1;2)

hesap kodlari

ID : 1006
ISLEM : hesap kodlari
MAKRO KODU : E1 Hücresi ile E15 HÜCRELERİNİN TOPLAMINI A1 E YAZ Sub Topla() [A1].Value = Application.Sum([E1:E15]) End Sub 'TEXTBOX'AGİRİLEN RAKAMLARI ÜÇ HANEDE BİR NOKTA İLE OTOMATİK AYIRIR Private Sub TextBox5_Change() TextBox5.Value = Format(TextBox5, "###,###") End Sub 'G SÜTUNUNA 50000 SATIR ÇIKARMA FORMÜLÜ GİRER(E2'DEN F2'Yİ ÇIKARIR) Private Sub CommandButton9_Click() Range("G2").Select ActiveCell.FormulaR1C1 = "=+RC[-2]-RC[-1]" Selection.AutoFill Destination:=Range("G2:G50000"), Type:=xlFillDefault Range("G2:G50000").Select End Sub TOPLAM FORMÜLÜNÜ HER DEFASINDA BİR ALTA TOPLAYAN KODLAR Sub Addieren() Dim rng As Range Set rng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) rng.Formula = "=SUM(A1:A" & rng.Row - 1 & ")" End Sub AKTİF HÜCREYE GİRİLEN RAKAMLARI ALTAKİ STATUSBAR DA TOPLAYAN KODLAR Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim myVar As Double myVar = Application.Sum(Columns(Target.Column)) If myVar 0 Then Application.StatusBar = Format(myVar, "###,###") Else Application.StatusBar = False End If End Sub HÜCRELERE VERİLEN AD TANIMLAMALARINI SİLER Sub DeleteRangeNames() Dim rName As Name For Each rName In ActiveWorkbook.Names rName.Delete Next rName End Sub FAREYLE SEÇTİĞİNİZ HÜCRELERDEKİ FORMÜLLERİ AÇIKLAMA OLARAK YAZDIRAN KODLAR Sub formulacikla() Dim cell As Range Selection.ClearComments For Each cell In Selection If cell.HasFormula Then cell.AddComment cell.Formula cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True End If Next cell End Sub MAKRO İLE TOPLAMA VE BÖLME YAPMA (YÜZDE ALMA) Sub topla_böl() Range("C1") = (Range("A1") / Range("A2")) * 100 End Sub 'VERİLERİ BİRLEŞTİRİR Sub birlestir() Range("A1").Select ActiveCell.FormulaR1C1 = _ "=CONCATENATE(R[1]C[0],R[1]C[1],R[1]C[2])" Range("A2").Select End Sub 'HÜCRELERE GİRİLEN SAYILARI YAZIYA ÇEVİRİR =Yaziyla(A1)formülü girildiğinde makro işler. Function Yaziyla(Sayi#) ReDim birler$(10), onlar$(10), basamak$(5) birler$(0) = "": birler$(1) = "Bir" birler$(2) = "İki": birler$(3) = "Üç" birler$(4) = "Dört": birler$(5) = "Beş" birler$(6) = "Altı": birler$(7) = "Yedi" birler$(8) = "Sekiz": birler$(9) = "Dokuz" onlar$(0) = "": onlar$(1) = "On" onlar$(2) = "Yirmi": onlar$(3) = "Otuz" onlar$(4) = "Kırk": onlar$(5) = "Elli" onlar$(6) = "Altmış": onlar$(7) = "Yetmiş" onlar$(8) = "Seksen": onlar$(9) = "Doksan" basamak$(1) = "": basamak$(2) = "Bin" basamak$(3) = "Milyon": basamak$(4) = "Milyar" basamak$(5) = "Trilyon" virgul2$ = "": cevap$ = "": onda$ = "" Say$ = Str$(Sayi#) virgul% = InStr(1, Say$, ".") If virgul% Then Say$ = Right$(Say$, Len(Say$) - virgul%) Select Case Len(Say$) Case 6: onda$ = "milyonda" Case 5: onda$ = "yüzbinde" Case 4: onda$ = "onbinde" Case 3: onda$ = "binde" Case 2: onda$ = "yüzde" Case 1: onda$ = "onda" End Select GoSub cevir virgul2$ = " virgül " + onda$ + " " + cevap$ cevap$ = "" Say$ = Str$(Sayi#) Say$ = Left(Say$, virgul% - 1) End If GoSub cevir 'If cevap$ = "" And Mid$(Str$(Sayi#), 2, 1) = 0 Then cevap$ = "Sıfır" Yaziyla = cevap$ + virgul2$ Exit Function cevir: x% = Len(Say$) Say$ = String$(3 - (x% - Int(x% / 3) * 3), 48) + Say$ x% = Len(Say$) / 3 For i% = 1 To x% uclu$ = Mid$(Say$, Len(Say$) - i% * 3 + 1, 3) Y% = Val(Mid$(uclu$, 1, 1)) O% = Val(Mid$(uclu$, 2, 1)) b% = Val(Mid$(uclu$, 3, 1)) yazi$ = "" If Y% 0 Then If Y% > 1 Then yazi$ = birler$(Y%) yazi$ = yazi$ + "Yüz" End If yazi$ = yazi$ + onlar$(O%) + birler$(b%) If yazi$ "" Then If LCase(yazi$) = "bir" And i% = 2 Then yazi$ = "" cevap$ = yazi$ + basamak$(i%) + cevap$ End If Next i% Return End Function -

hesap makinasi çağirir

ID : 1007
ISLEM : hesap makinasi çağirir
MAKRO KODU : HESAP MAKİNASINI AKTİF YAPAR Sub Hesap_makinesi() Application.ActivateMicrosoftApp Index:=0 End Sub

hesap makinesi açma

ID : 1008
ISLEM : hesap makinesi açma
MAKRO KODU : Option Explicit Private Declare Function OpenProcess Lib "kernel32" ( _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" ( _ ByVal lnghProcess As Long, _ lpExitCode As Long) As Long '// If your going to be working with Systems that support security '// settings eg NT, XP the access will be checked against any '// security descriptor for the target process, so use this Const '// Sets all possible access flags for the process object. Private Const PROCESS_ALL_ACCESS = &H1F0FFF Public Function ShlProc_IsRunning(ShellReturnValue As Long) As Boolean Dim lnghProcess As Long Dim lExitCode As Long Dim lRet As Long '//Get the process handle lnghProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ShellReturnValue) If lnghProcess 0 Then '// The GetExitCodeProcess function retrieves the '// termination status of the specified process. GetExitCodeProcess lnghProcess, lExitCode If lExitCode 0 Then '// Process still ALIVE! ShlProc_IsRunning = True Else '// YES...finished @ last ShlProc_IsRunning = False End If End If End Function Sub ShellTester() Dim RetVal As Long '// '// When you Shell out to an Application the Return Value '// is the Applications Task ID '// in order to determine if it has Terminated we need to check '// if there is an existing process object '// > OpenProcess function opens an existing process object. '// On Error Resume Next '// On WinXP Calc.exe @ C:\WINDOWS\System32\ '// On Win9x Calc.exe @ C:\WINDOWS\ RetVal = Shell("C:\WINDOWS\System32\CALC.EXE", 1) On Error GoTo 0 If RetVal = 0 Then MsgBox "NoGo!" & vbCr & "Check your Path": End '// Ok, lets loop until the App process is terminated! Do While ShlProc_IsRunning(RetVal) = True DoEvents Loop MsgBox "Program finished!" & vbCr & "Lets continue on now!" End Sub -

hesap makinesi çağırma

ID : 1009
ISLEM : hesap makinesi çağırma
MAKRO KODU : Sub Hesap_makinesi() Application.ActivateMicrosoftApp Index:=0 End Sub

hesap makinesini açma kapama

ID : 1010
ISLEM : hesap makinesini açma kapama
MAKRO KODU : Option Explicit '// Declare the Required API's '// these handle the Calculator Menu Private Declare Function GetSystemMenu _ Lib "user32" ( _ ByVal hWnd As Long, _ ByVal bRevert As Long) _ As Long Private Declare Function DeleteMenu _ Lib "user32" ( _ ByVal hMenu As Long, _ ByVal nPosition As Long, _ ByVal wFlags As Long) _ As Long '// used to get the Windows Dir Private Declare Function GetWindowsDirectory _ Lib "kernel32" _ Alias "GetWindowsDirectoryA" ( _ ByVal lpBuffer As String, _ ByVal nSize As Long) _ As Long '// used to find the calculator Window Private Declare Function FindWindow _ Lib "user32" _ Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) _ As Long '// used to CLOSE the calcul7ator Private Declare Function PostMessage _ Lib "user32" _ Alias "PostMessageA" ( _ ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) _ As Long '// Used to set the Windows Style Private Declare Function SetWindowPos _ Lib "user32" ( _ ByVal hWnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) _ As Long '// Positions Private Const HWND_TOPMOST = -1 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_SHOWWINDOW = &H40 Private Const WM_CLOSE = &H10 Private Const MF_BYCOMMAND As Long = &H0 Private Const SC_CLOSE = &HF060 Dim HoldVar As New Class1 Sub WinCalculator_Open() '// Need to consider International Versions Dim strSysDir1 As String Dim strSysDir2 As String Dim Fso As Object Dim Ret As Long Dim strTmp1 As String Dim strTmp2 As String '// make sure only ONE instance of Calc is open '// Unless you want more? then just remove this code. If HoldVar.hdlCalc Then Exit Sub '// On Error Resume Next '// get users [System Dir] > Typical location of Calculator Set Fso = CreateObject("Scripting.FileSystemObject") strSysDir1 = Fso.GetSpecialFolder(1) '// get users [Windows Dir] strTmp2 = String(256, Chr(0)) strSysDir2 = Left(strTmp2, GetWindowsDirectory(strTmp2, Len(strTmp2))) '// Calculator is typically in the [System Dir] or [Windows] '// lets see! Ret = Shell(strSysDir1 & "\calc.exe", 1) If Ret = 0 Then Ret = Shell(strSysDir2 & "\calc.exe", 1) If Ret = 0 Then GoTo NoGo On Error GoTo 0 '// Lets Keep these variable to reference later '// This is done via Class variable HoldVar.hdlCalc = FindWindow(vbNullString, "calculator") '// Disable the CLOSE button > so that we only close '// the instance of the calculator via Code WinCalculator_RemoveCloseMenu HoldVar.hdlCalc '// Make calculator Applet stay ONTOP SetWindowPos HoldVar.hdlCalc, _ HWND_TOPMOST, _ 0, 0, 0, 0, _ SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE Exit Sub NoGo: MsgBox "Couldn't find Calc.exe file!... " & _ "In either............" & vbCrLf & vbCrLf & _ strSysDir1 & vbCrLf & " OR " & vbCrLf & _ strSysDir2, vbCritical, "Better check!" End Sub Sub WinCalculator_Close() '// If HoldVar.hdlCalc Then PostMessage HoldVar.hdlCalc, WM_CLOSE, 0&, 0& '// Reset the Windowhandle variable HoldVar.hdlCalc = 0 End Sub Sub WinCalculator_RemoveCloseMenu(hWnd As Long) '// Removes the CLOSE button on calculator Dim hMenu As Long hMenu = GetSystemMenu(hWnd, 0) Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND) End Sub ‘classmodüle Option Explicit Public hdlCalc As Double Public strCalcCaption As String

hesaplama seçenekleri penceresi

ID : 1011
ISLEM : hesaplama seçenekleri penceresi
MAKRO KODU : Sub Dialog_09() Application.Dialogs(xlDialogCalculation).Show End Sub

hesaplama seçenekleri penceresi

ID : 1012
ISLEM : hesaplama seçenekleri penceresi
MAKRO KODU : Sub Dialog_46() Application.Dialogs(xlDialogOptionsCalculation).Show End Sub

hizalama penceresi

ID : 1013
ISLEM : hizalama penceresi
MAKRO KODU : Sub Dialog_04() Application.Dialogs(xlDialogAlignment).Show End Sub

hoparlörden beep sesi çıkarmak

ID : 1014
ISLEM : hoparlörden beep sesi çıkarmak
MAKRO KODU : Private Sub Command1_Click() Beep End Sub

htm uzantılı dosyayı açma

ID : 1015
ISLEM : htm uzantılı dosyayı açma
MAKRO KODU : Sub Help() Call Shell("hh " & ThisWorkbook.Path & "\varCheck.htm", vbMaximizedFocus) End Sub

hucre ye geldiginde makro calissin

ID : 1016
ISLEM : hucre ye geldiginde makro calissin
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range("a1:a10")) Is Nothing Then Exit Sub makroadi() End Sub

hücre a1 deki yazı boyutu ve karekterini sadece yazıcıya gönderirken arial-italik ve 14 punto yapar

ID : 1017
ISLEM : hücre a1 deki yazı boyutu ve karekterini sadece yazıcıya gönderirken arial-italik ve 14 punto yapar
MAKRO KODU : Sub Printr() ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14Benim Tercihim" & Chr(13) _ & Sheets(1).Range("A1") ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub

hücre alanı kesme, seçili alanı kesme

ID : 1018
ISLEM : hücre alanı kesme, seçili alanı kesme
MAKRO KODU : Range(“A1:E10”).Cut Selection.Cut

hücre alanı seçme

ID : 1019
ISLEM : hücre alanı seçme
MAKRO KODU : Range(“A1:E10”).Select

hücre biçimi textboxta da aynı biçimde

ID : 1020
ISLEM : hücre biçimi textboxta da aynı biçimde
MAKRO KODU : Private Sub CommandButton1_Click() Range("a1").Select ActiveCell.Formula = TextBox1 End Sub

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