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


değişen hücreleri gösterme

ID : 661
ISLEM : değişen hücreleri gösterme
MAKRO KODU : Project Explorerden "This Workbook" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın. 'Normal module sayfasına eklerseniz çalışmaz. Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger 0 Then yenideger = Range(adres).Value If deger yenideger Then Call yaz(deger, adres, yenideger) End If End If Range("IV1").Value = ActiveCell.Address Range("IV2").Value = ActiveCell.Value End Sub -

değişik kopyalama

ID : 662
ISLEM : değişik kopyalama
MAKRO KODU : Sub kopyala() Dim pir1 As Range, pir2 As Range Set pir1 = Range("A1:B2") Set pir2 = Range("F1:G2") pir2.Value = pir1.Value pir2.NumberFormat = pir1.NumberFormat End Sub

değişikliklerin a kolonuna saat & tarihli kaydedilmesi

ID : 663
ISLEM : değişikliklerin a kolonuna saat & tarihli kaydedilmesi
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Me.Cells(Target.Row, 1) = Now '1 steht für Spalte A, für Spalte H waere es die 8 Application.EnableEvents = True End Sub

değişken ve döngü ile 1 den 10 a kadar sayıların toplamı

ID : 664
ISLEM : değişken ve döngü ile 1 den 10 a kadar sayıların toplamı
MAKRO KODU : Sub Accumulate() Dim n As Integer Dim t As Integer For n = 1 To 10 t = t + n Next n MsgBox " The total is " & t End Sub

değişkene toplam atamak

ID : 665
ISLEM : değişkene toplam atamak
MAKRO KODU : Sub a() b = WorksheetFunction.Sum(Sheets("sayfa1").Range("A1:A50")) End Sub 'bu kodda b değişkenine A1:A50 arasındaki değerlerin toplamı atanmıştır.

değiştir penceresi

ID : 666
ISLEM : değiştir penceresi
MAKRO KODU : Sub Dialog_34() Application.Dialogs(xlDialogFormulaReplace).Show End Sub

del tuşu 2. sütunda çalışmasın

ID : 667
ISLEM : del tuşu 2. sütunda çalışmasın
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then Application.OnKey "{Del}", "" Else Application.OnKey "{Del}" End If End Sub

demo program yapma

ID : 668
ISLEM : demo program yapma
MAKRO KODU : Sub demo() Dim saat1 As Date Dim saat2 As Date saat1 = "15/10/2005" saat2 = Date If saat2 > saat1 Then MsgBox ("Süreniz dolmuş üzgünüm.") ActiveWorkbook.Close End If MsgBox ("Kullanım için " & saat1 - saat2 & " gününüz kalmıştır.") If sure1 = sure2 Then MsgBox "Bu gün SON GÜN" End If End Sub

ders ortalamalarını hesaplamak

ID : 669
ISLEM : ders ortalamalarını hesaplamak
MAKRO KODU : 1 ADET COMBO '1 ADET COMMAND '4 ADET TEXT '5 ADET LABEL Private Sub Command1_Click() Label5.Caption = (Val(Text1) + Val(Text2) + Val(Text3) + Val(Text4)) / 4 End Sub Private Sub UserForm_Activate() Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" Combo1.AddItem "DERSİNİZİN İSMİ" End Sub Private Sub Text1_Change() If Val(Text1) > 100 Or 0 > Val(Text1) Then MsgBox "GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR" Text1.Text = "" End If End Sub Private Sub Text2_Change() If Val(Text2) > 100 Or Val(Text2) 100 Or 0 > Val(Text3) Then MsgBox "GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR" Text3.Text = "" End If End Sub Private Sub Text4_Change() If Val(Text4) > 100 Or 0 > Val(Text4) Then MsgBox "GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR" Text4.Text = "" End If End Sub -

deşiklik yapılan hücredeki eski değeri görme

ID : 670
ISLEM : deşiklik yapılan hücredeki eski değeri görme
MAKRO KODU : Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger 0 Then yenideger = Range(adres).Value If deger yenideger Then Call yaz(deger, adres, yenideger) End If End If Range("IV1").Value = ActiveCell.Address Range("IV2").Value = ActiveCell.Value End Sub -

detaylı karşılama, kapama

ID : 671
ISLEM : detaylı karşılama, kapama
MAKRO KODU : Sub Auto_Open() Application.StatusBar = " LİDER GROUP ©2005 / - MALİYET ANALİZ LİSTELERİ -" Sheets("ANA SAYFA").Select Range("A1").Select Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, "hh:mm:ss") tarih = Format(tarih, "d mmmm yyyy dddd") MsgBox " MERHABA " & kullanici & ", HOŞ GELDİNİZ!" & Chr(13) & Chr(13) & _ "Tarih : " & tarih & Chr(13) & Chr(13) _ & "Saat : " & saat & Chr(13) & Chr(13) _ & "Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler." & Chr(13) & Chr(13), vbApplicationModal, " LİDER GROUP 2005® " End Sub Sub Auto_Close() Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, "hh:mm:ss") tarih = Format(tarih, "d mmmm yyyy dddd") MsgBox " GÖRÜŞMEK ÜZERE " & kullanici & Chr(13) & Chr(13) & _ "Tarih : " & tarih & Chr(13) & Chr(13) _ & "Saat : " & saat & Chr(13) & Chr(13) _ & "Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler." & Chr(13) & Chr(13), vbApplicationModal, " LİDER GROUP 2005® " ActiveWorkbook.Save Application.DisplayAlerts = False ActiveWorkbook.Close False Application.Quit End Sub

diger kitaptaki makroyu çaliştirmak

ID : 672
ISLEM : diger kitaptaki makroyu çaliştirmak
MAKRO KODU : üzerindeki bir makinedeki bir excel kitabının içindeki makroyu kendi makinenizden çalıştırmak Kod: Application.Run "\\makineadi\klasoradi\kitapadi.xls!makroadi" eğer kitaplar aynı makine üzerinde ise Kod: Application.Run "c:\klasoradi\kitapadi.xls!makroadi"

diğer çalışma kitabındaki modülden makro çalıştırma

ID : 673
ISLEM : diğer çalışma kitabındaki modülden makro çalıştırma
MAKRO KODU : Sub Essai() Run ("Kitap1.xls!Module1.MAkro1") End Sub

diğer formdaki command butonu çalıştırmak

ID : 674
ISLEM : diğer formdaki command butonu çalıştırmak
MAKRO KODU : Form2 VBA Public Sub Buton1_Click() Msgbox "Merhaba" End Sub 'Form1 VBA 'da Private Sub Buton1_Click() userform2.buton1_click End Sub

diğer kitaptaki makroyu çalıştırma

ID : 675
ISLEM : diğer kitaptaki makroyu çalıştırma
MAKRO KODU : Application.Run "kitap2.xls!makro1"

dikdörtgen silme

ID : 676
ISLEM : dikdörtgen silme
MAKRO KODU : Sub dortgen_sil() For Each Rectangle In ActiveSheet.Shapes Rectangle.Delete Next End Sub

disket etiketlendirme

ID : 677
ISLEM : disket etiketlendirme
MAKRO KODU : Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" _ (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long Sub NommeDSK() retval = SetVolumeLabel("a:\", "MaDisquette") 'pour supprimer le label 'retval = SetVolumeLabel("a:\", vbNullString) End Sub

disket formatlama

ID : 678
ISLEM : disket formatlama
MAKRO KODU : Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private hWnd As Long Const SHFMT_DRV_A = 0 Const SHFMT_DRV_B = 1 Const SHFMT_ID_DEFAULT = &HFFFF Const SHFMT_OPT_QUICKFORMAT = 0 Const SHFMT_OPT_FULLFORMAT = 1 Const SHFMT_OPT_SYSONLY = 2 Const SHFMT_ERROR = -1 Const SHFMT_CANCEL = -2 Const SHFMT_NOFORMAT = -3 Private Sub format() Dim Res As Long hWnd = FindWindow(vbNullString, Me.Caption) Res = SHFormatDrive(hWnd, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT) Select Case Res Case SHFMT_ERROR MsgBox "Hata.", vbCritical Case SHFMT_CANCEL MsgBox "İptal edildi.", vbInformation Case SHFMT_NOFORMAT MsgBox "Formatlı değil.", vbInformation Case Else MsgBox "Formatlama bitti." End Select End Sub Private Sub CommandButton1_Click() format End Sub

diskete yedekleme

ID : 679
ISLEM : diskete yedekleme
MAKRO KODU : Sub SaveWorkbookBackupToFloppyA() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub Set awb = ActiveWorkbook If awb.path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir("A:" & BackupFileName) "" Then Kill "A:" & BackupFileName End If With awb Application.StatusBar = "Saving this workbook..." .Save Application.StatusBar = "Saving this workbook backup..." .SaveCopyAs "A:" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox "Backup Copy Not Saved!", vbExclamation, ThisWorkbook.Name End If End Sub -

disketten .bat dosyası açma

ID : 680
ISLEM : disketten .bat dosyası açma
MAKRO KODU : Option Explicit '//The Shell function runs other programs asynchronously so what '//What you basically have to do is Open the existing Process '//for the running Application and, LOOP & WAIT for the processes return state '//ie when the specified process is in the signaled state '//or a timeout occurs. Private Declare Function OpenProcess Lib "kernel32" ( _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" ( _ ByVal hHandle As Long, _ ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib "kernel32" ( _ ByVal hObject As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" ( _ ByVal hProcess As Long, _ lpExitCode As Long) As Long '&HFFFF Private Const SYNCHRONIZE = &H100000 '// Note:SYNCHRONIZE Windows NT/2000 Private Const INFINITE = &HFFFF 'OR -1& '// INFINITE, the function’s time-out interval never elapses. Private Const STILL_ACTIVE = &H103 Public Function ShellAndWait(ByVal BatFile As String) ' ' Shells a new process and waits for it to complete. ' Calling application is totally non-responsive while ' new process executes. ' Dim PID As Long Dim hProcess As Long Dim nRet As Long '// Unlike other Functions Shell generates an error '// instead of returning a 0 so handling the error '// = Application NOT started. On Error Resume Next PID = Shell(BatFile, vbMinimizedNoFocus) If Err Then '// handle the error here and End MsgBox "Could NOT exercute:= " & BatFile End End If On Error GoTo 0 '// SYNCHRONIZE For Windows NT/2000: '// Enables using the process handle in any of the wait '// functions to wait for the process to terminate. '// obviously with NT you need access rights. hProcess = OpenProcess(SYNCHRONIZE, False, PID) '// Just set the dwMilliseconds to INFINITE to initiate a Loop nRet = WaitForSingleObject(hProcess, INFINITE) Do GetExitCodeProcess hProcess, nRet DoEvents Loop While nRet = STILL_ACTIVE CloseHandle hProcess End Function Sub OpenFileAndWait() Dim sApp As String '// Define the Application FullPath here sApp = "C:\A\Batch.bat" 'sApp = "C:\windows\system32\calc.exe" '// Lets DoIt ShellAndWait sApp '// Tell me if Successful MsgBox "Finished running task!" End Sub

diyagram çizme

ID : 681
ISLEM : diyagram çizme
MAKRO KODU : Sub polygon() 'zeichnet Polygon Application.ScreenUpdating = False anzeck = InputBox("Wieviele Ecken ?") If anzeck = Empty Or Not IsNumeric(anzeck) Or anzeck -

dizi yöntemi sayfa seçme

ID : 682
ISLEM : dizi yöntemi sayfa seçme
MAKRO KODU : Sub sec() Worksheets(Array(1, 3, 5)).Select End Sub

dizindeki en son klasör ya da dosya ismini verir

ID : 683
ISLEM : dizindeki en son klasör ya da dosya ismini verir
MAKRO KODU : Sub Dizindeki_Son_İsim() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.GetBaseName("C:\SXSİ\Deneme\Ben.txt") MsgBox a End Sub

dizindeki sürücü harfini verir

ID : 684
ISLEM : dizindeki sürücü harfini verir
MAKRO KODU : Sub Sürücü_İsmi() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.GetDriveName("C:\SXSİ\Deneme\Ben.txt") MsgBox a End Sub

doğum gününü bulma

ID : 685
ISLEM : doğum gününü bulma
MAKRO KODU : Dim d_tarih Do d_tarih = InputBox("Doğum Tarihiniz Ör:01/04/1979", "Doğum Tarihinizi Yazın Lütfen") Loop While Not IsDate(d_tarih) MsgBox (WeekdayName(Weekday(d_tarih, 0), False, 0) + " " + "Günü Doğmuşsunuz.")

dolar okutma

ID : 686
ISLEM : dolar okutma
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 Dollars" If vNumber = 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 -

dolaylı makro

ID : 687
ISLEM : dolaylı makro
MAKRO KODU : aktif sayfaya açılır kutu ekleyin. Referansını A sütununa verin. A sütunundakileri dolaylı olarak b14 te gösterir Sub yaz() ActiveSheet.Shapes("Drop Down 1").Select [b14] = Evaluate("=INDIRECT(""A" & Selection.Value & """" & ")") [b13].Select End Sub

dolu alanlaı yazdırma

ID : 688
ISLEM : dolu alanlaı yazdırma
MAKRO KODU : Sub doluyazdir() ActiveSheet.UsedRange.Select Selection.PrintOut End Sub

dolu hücreleri seçer ve büyük harfe çevirir

ID : 689
ISLEM : dolu hücreleri seçer ve büyük harfe çevirir
MAKRO KODU : Sub doluhucre_sec() Dim range As range Sheets("Sayfa1").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = UCase(range.Value) End If Next End Sub

dolu hücreleri seçer ve küçük harfe çevirir

ID : 690
ISLEM : dolu hücreleri seçer ve küçük harfe çevirir
MAKRO KODU : Sub doluhucre_sec() Dim range As range Sheets("Sayfa1").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = LCase(range.Value) End If Next End Sub

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