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


mesaj kutusuyla formül girme

ID : 1531
ISLEM : mesaj kutusuyla formül girme
MAKRO KODU : Sub Adjust() Dim Target As Range Dim J As Integer Dim sForm As String Dim sMod As String Set Target = ActiveSheet.Range(ActiveWindow.Selection.Address) sMod = InputBox("Formula to add?") If sMod > "" Then For J = 1 To Target.Cells.Count If Target.Cells(J).HasFormula Then sForm = Target.Cells(J).Formula sForm = "=(" & Mid(sForm, 2, 500) & ")" sForm = sForm & sMod Target.Cells(J).Formula = sForm Else sForm = "=" & Target.Cells(J).Value & sMod Target.Cells(J).Formula = sForm End If Next J End If End Sub

mesaj örnekleri

ID : 1532
ISLEM : mesaj örnekleri
MAKRO KODU : Sub msg1() MsgBox "Test MSG1", vbInformation, "Information fichier" End Sub Sub msg11() MsgBox "Test MSG11", 64, "Information fichier" End Sub 'Indique un message d'exclamation Sub msg2() MsgBox "Test MSG2", vbExclamation, "Information fichier" End Sub 'Idem avec la valeur 48 Sub msg22() MsgBox "Test MSG22", 48, "Information fichier" End Sub 'En plus clair Sub msg3() MsgBox prompt:="Il est l'heure de votre RDV", _ Buttons:=vbExclamation, Title:="ATTENTION" End Sub

mesaj verdirip kapatma

ID : 1533
ISLEM : mesaj verdirip kapatma
MAKRO KODU : Sub Send_Excel_Message() Dim MyMessage As Object, MyOutApp As Object 'InitializeOutlook = True Set MyOutApp = CreateObject("Outlook.Application") Set MyMessage = MyOutApp.CreateItem(0) With MyMessage .To = "mahmut_bayram@mynet.com" .Subject = "Testmeldung von Excel2000 " & Date & Time '.body = "Selamun Aleyküm" & vbCrLf & "Nasılsınız Mahmut Bey" .HTMLBody = "Afiyettesinizdir" & vbCrLf & "İnşaallah." .Display .Save SendKeys "%S" End With 'MyOutApp.Quit ‘ baştaki işaretş kaldırırsanız mesaj gönderen uygulamayı kapatır. Set MyOutApp = Nothing Set MyMessage = Nothing End Sub

mesajdan sonra makro

ID : 1534
ISLEM : mesajdan sonra makro
MAKRO KODU : Sub Macro1() MsgBox ("This is Macro1") Call Macro2 End Sub

mesajla boş olup olmadığını kontrol etme

ID : 1535
ISLEM : mesajla boş olup olmadığını kontrol etme
MAKRO KODU : Sub TestValeurVide() Dim MaValeur, MonTest MaValeur = Empty 'il y a une valeur MonTest = IsEmpty(MaValeur) ' Test si ma valeur est vide MsgBox MonTest 'Retourne Vrai MaValeur = Null 'il n'y a pas de valeur MonTest = IsEmpty(MaValeur)' Test si ma valeur est vide (EstVide) MsgBox MonTest 'Retourne Faux MaValeur = Null 'il n'y a pas de valeur MonTest = Not IsEmpty(MaValeur) ' Test si ma valeur n'est pas vide (Non EstVide) MsgBox MonTest 'Retourne Vrai End Sub

mesajla numerik veya numerik olmadığını kontrol etme

ID : 1536
ISLEM : mesajla numerik veya numerik olmadığını kontrol etme
MAKRO KODU : Sub Valeurnum() Dim MaValeur, MaValeur2, MonTest, MonTest2 MaValeur = "4578" MonTest = IsNumeric(MaValeur) 'Retourne Vrai MsgBox MonTest MaValeur = "4578,456" MonTest = IsNumeric(MaValeur) 'Retourne Vrai MsgBox MonTest MaValeur2 = "daniel" MonTest2 = IsNumeric(MaValeur2) 'Retourne Faux MsgBox MonTest2 End Sub

mesajla tarih formatı olup olmadığını kontrol etme

ID : 1537
ISLEM : mesajla tarih formatı olup olmadığını kontrol etme
MAKRO KODU : Sub ValeurDate() Dim MaDate, NonDate, TestDate, TestDate2 MaDate = "02 Mai 2002": NonDate = "Daniel" TestDate = IsDate(MaDate) 'Retourne Vrai MsgBox TestDate TestDate2 = IsDate(NonDate) 'Retourne Faux MsgBox TestDate2 End Sub

metin kutusuna girlilen yazinin para birimi şeklinde olmasi

ID : 1538
ISLEM : metin kutusuna girlilen yazinin para birimi şeklinde olmasi
MAKRO KODU : TextBox nesnesine girildiğinde bu işin yapılması için biraz daha uzun kod yazmak lazım. Onun yerine, TextBox nesnesinden "cursor - imleç" çıktığında bu işin yapılmasını istersen; Kod: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, "#,### TL") End Sub Ve, eğer az önce rastladığım senin diğer bir mesajında bu işin yapılmasını istersen; Kod: Private Sub TextBox1_Change() RefreshTxtBx End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, "#,### TL") End Sub ' Private Sub TextBox2_Change() RefreshTxtBx End Sub ' Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox2 = Format(TextBox2, "#,### TL") End Sub ' Private Sub RefreshTxtBx() Dim Val1 As Double, Val2 As Double On Error Resume Next Val1 = TextBox1 Val2 = TextBox2 On Error GoTo 0 TextBox3 = Format(Val1 + Val2, "#,### TL") End Sub

metin kutusunun formatini ayarlamak

ID : 1539
ISLEM : metin kutusunun formatini ayarlamak
MAKRO KODU : Sadece sayı yazmak içinde aşağıdaki linki inceleyiniz. visual basic kodu: -------------------------------------------------------------------------------- Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, "###-### ## ##") End Sub -------------------------------------------------------------------------------- tutarda sadece sayısal değer (sayının 1.234,56 şeklinde) yazılması için visual basic kodu: -------------------------------------------------------------------------------- Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If IsNumeric(TextBox1) = True Then TextBox1 = Format(TextBox1, "###,###.##") Exit Sub End If TextBox1 = "GİRİLEN DEÐER HATALIDIR" End Sub

metinleri büyük & küçük harfe çevirir

ID : 1540
ISLEM : metinleri büyük & küçük harfe çevirir
MAKRO KODU : Metni büyük harfli yapmak için şu makroyu kullanın: Sub BuyukHarf() For Each c In Selection.Cells c.Value=Ucase$(c.Value) Next c End Sub Metni küçük harf yapmak içinse şu makroyu kullanın: Sub KucukHarf() For Each c In Selection.Cells c.Value=Lcase$(c.Value) Next c End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARI BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range("a1:ı1000") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Value = UCase(RaZelle.Value) End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARIN BAŞ HARFİNİ BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range("a1:ı1000") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then If RaZelle "" Then RaZelle.Value = UCase(Mid(RaZelle.Value, 1, 1)) _ & LCase(Mid(RaZelle.Value, 2, Len(RaZelle.Value) - 1)) End If End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub -

metinleri büyük&küçük harfe çevirir

ID : 1541
ISLEM : metinleri büyük&küçük harfe çevirir
MAKRO KODU : Metni büyük harfli yapmak için şu makroyu kullanın: Sub BuyukHarf() For Each c In Selection.Cells c.Value=Ucase$(c.Value) Next c End Sub Metni küçük harf yapmak içinse şu makroyu kullanın: Sub KucukHarf() For Each c In Selection.Cells c.Value=Lcase$(c.Value) Next c End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARI BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range("a1:ı1000") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Value = UCase(RaZelle.Value) End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARIN BAŞ HARFİNİ BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range("a1:ı1000") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then If RaZelle "" Then RaZelle.Value = UCase(Mid(RaZelle.Value, 1, 1)) _ & LCase(Mid(RaZelle.Value, 2, Len(RaZelle.Value) - 1)) End If End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub -

microsoft outlookdan uyari e-maili göndersin

ID : 1542
ISLEM : microsoft outlookdan uyari e-maili göndersin
MAKRO KODU : Biliyorsunuzdur mutlaka John Walkenbachın bir api si var.Aşağıdaki gibi. Kod: 'Windows API function declaration Private Declare Function PlaySound Lib "winmm.dll" _ Alias "PlaySoundA" (ByVal lpszName As String, _ ByVal hModule As Long, ByVal dwFlags As Long) As Long Function Alarm(Cell, Condition) Dim WAVFile As String Const SND_ASYNC = &H1 Const SND_FILENAME = &H20000 On Error GoTo ErrHandler If Evaluate(Cell.Value & Condition) Then WAVFile = ThisWorkbook.Path & "\sound.wav" 'Edit this statement Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME) Alarm = True Exit Function End If ErrHandler: Alarm = False End Function Kod: =Alarm(A1;">=1000") Þimdi benim sorunum şöyle , E sütununda tarihler var.Bu tarihlerden 10 gün önce alarm versin ve F sütunundaki kişilere Microsoft Outlookdan uyarı e-maili göndersin. Bu mümkün mü acaba? _________________ Haluk Moderatör -------------------------------------------------------------------------------- Excel ile e-mail gönderilecekse e-mail client olarak MS Outlook'un kullanılması her zaman daha iyidir. Çünkü MS Outlook da bir Office programı olduğu için, Excel VBA'de MS Outlook'a referans vererek bazı işler daha kolay yapılabilir. Aşağıdaki kodu çalıştırmadan önce Excel VBE'de Tools | References kısmından MS Outlook 9.0 Object Libray referansının eklenmesi gerekir. (MS Outlook versiyonuna göre 10 veya 11 de olabilir.) PC'nin tarihi ile E sütunundaki tarihleri kontrol edip, 10 günlük farkı gördüğü yerde F sütunundaki geçerli e-mail adresine bir e-mail, MS Outlook ile aşağıdaki gibi bir kodla gönderilebilir. Kod: Sub MultiEmail() Dim OutApp As Outlook.Application Dim NewMail As Outlook.MailItem Dim noE As Integer, i As Integer noE = Cells(65536, 5).End(xlUp).Row For i = 1 To noE If Cells(i, 5) = Date - 10 Then Set OutApp = New Outlook.Application Set NewMail = CreateItem(olMailItem) With NewMail .To = Cells(i, 6).Text .Subject = "Deneme" .Body = "Bu e-mail deneme amacıyla gönderilmiştir." .Save .Send End With Set NewMail = Nothing Set OutApp = Nothing End If Next End Sub Eğer bu kodun çalıştırıldığı PC'de ilgili güvenlik yaması kurulmuş ise Windows kullanıcıyı ikaz eder ve başka bir programın e-mail göndermeye çalıştığına dair kullanıcıyı uyarır. Bu yama kurulu değilse, böyle bir problem olmaz

midi çalma

ID : 1543
ISLEM : midi çalma
MAKRO KODU : Sub PlayMIDI() Dim Player Player = Shell("C:\Program Files\Windows Media Player\wmplayer.exe") C:\Songs\regypti.mid", 6) AppActivate Player End Sub

midi çalma

ID : 1544
ISLEM : midi çalma
MAKRO KODU : Sub Play_Sound() Dim Player Player = Shell("C:\Program Files\Windows Media Player\wmplayer.exe,C:\canyon.mid", 6) AppActivate Player End Sub

midi dosyası çalma

ID : 1545
ISLEM : midi dosyası çalma
MAKRO KODU : Sub PlayMIDI() Dim Player Player = Shell("C:\Progra~1\Window~1\mplayer2.exe C:\Songs\regypti.mid", 6) AppActivate Player End Sub

mini email

ID : 1546
ISLEM : mini email
MAKRO KODU : Sub Mini_Mail() Shell "C:\Program Files\Microsoft Office\Office10\OUTLOOK.exe" ActiveWorkbook.SendMail Recipients:="mahmut_bayram@mynet.com", Subject:="Test" End Sub

modül gizleme

ID : 1547
ISLEM : modül gizleme
MAKRO KODU : Sub ModulGizle() Module(1).Visible = xlVeryHidden End Sub Sub ModulGoster() Module(1).Visible = True End Sub

modül silme

ID : 1548
ISLEM : modül silme
MAKRO KODU : Sub Loeschen() With Workbooks("Kitap1.xls").VBProject .VBComponents.Remove .VBComponents("Modul1") End With End Sub

modüle yazılan kodun sayfada aktif yapılması

ID : 1549
ISLEM : modüle yazılan kodun sayfada aktif yapılması
MAKRO KODU : BU KOD MODÜL İÇİNE YAZILAN KODU SAYFA İÇİNDE AKTİF HALE GETİRİR. Private Sub Worksheet_SelectionChange(ByVal Target As Range) Call Makro1 End Sub

modüle yazilan kodu sayfada aktif yapar

ID : 1550
ISLEM : modüle yazilan kodu sayfada aktif yapar
MAKRO KODU : BU KOD MODÜL İÇİNE YAZILAN KODU SAYFA İÇİNDE AKTİF HALE GETİRİR. Private Sub Worksheet_SelectionChange(ByVal Target As Range) Call Makro1 End Sub

mouse tıklayınca hesaplama

ID : 1551
ISLEM : mouse tıklayınca hesaplama
MAKRO KODU : Private Sub TextBox25_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) On Error Resume Next If TextBox5 = Empty Then : Exit Sub Else TextBox25.Value = WorksheetFunction.Round((TextBox5.Value * 0.7), 2) End If End Sub

mp3 dosyası çalma

ID : 1552
ISLEM : mp3 dosyası çalma
MAKRO KODU : Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _ (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _ ByValuReturnLength As Long, ByVal hwndCallback As Long) As Long Public Declare Function GetShortPathName Lib "kernel32" Alias _ "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As _ String, ByVal cchBuffer As Long) As Long Sub LanceMP3() X = ThisWorkbook.Path joueMP3 (X & "\monfichier.mp3") End Sub Public Sub joueMP3(ByVal Mp3 As String) Dim Tmp As Long, Tmp2 As String 'Screen.MousePointer = vbHourglass Tmp2 = NomCourt(Mp3) Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&) Tmp = mciSendString("open " & Tmp2 & " type MPEGVideo alias MP3_Device", _ vbNullString, 0&, 0&) If Tmp = 0 Then Tmp = mciSendString("play Mp3_Device", vbNullString, 0&, 0&) If Tmp 0 Then Screen.MousePointer = 0 MsgBox "Incapable de jouer ce Mp3" 'Else ' Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&) End If Else 'Screen.MousePointer = 0 MsgBox "Incapable de jouer ce Mp3" End If 'Screen.MousePointer = 0 End Sub Public Sub StopMP3() Dim Tmp As Long Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&) End Sub Private Function NomCourt(ByVal Fichier As String) As String Dim Tmp As String * 255, Tmp2 As Byte Tmp2 = GetShortPathName(Fichier, Tmp, Len(Tmp)) If Tmp2 > 0 Then NomCourt = Left(Tmp, Tmp2) End If End Function -

mp3 dosyasının süresini hesaplatın (dosya yolunu yazın ve o hücreyi seçin)

ID : 1553
ISLEM : mp3 dosyasının süresini hesaplatın (dosya yolunu yazın ve o hücreyi seçin)
MAKRO KODU : örneğin A5 hücresine C:\zeynel.mp3 yazın ve a5 hücresini seçin Option Explicit ' Modul ' benötigte API-Deklarationen Private Declare Function mciSendString Lib "winmm.dll" _ Alias "mciSendStringA" ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" _ Alias "GetShortPathNameA" ( _ ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, _ ByVal cchBuffer As Long) As Long ' Ermittelt die Länge einer MP3-Datei Sub Länge_MP3() Dim song As String Dim zeile As Integer zeile = ActiveCell.Row song = Cells(zeile, 1).Value '"C:\My Music\MP3\ABBA - Mamma Mia.mp3" MsgBox ("Titellänge: " & Chr(13) & Chr(13) & FormatTime(GetMP3Length(song)) & " min.") End Sub ' in Millisekunden Function GetMP3Length(ByVal strFileName As String) As Long Dim strBuffer As String Dim lRet As Long Dim sReturn As String ' Da die mciSendString Funktion mit langen Dateinamen ' nicht korrekt arbeitet, muss zuvor der kurze ' 8.3 Dateiname der MP3-Datei ermittelt werden. strBuffer = Space$(255) lRet = GetShortPathName(strFileName, strBuffer, Len(strBuffer)) If lRet 0 Then strFileName = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1) End If ' MP3-Datei öffnen mciSendString "open " & strFileName & _ " type MPEGVideo alias mp3audio", 0, 0, 0 ' Länge der Datei in Millisekunden auslesen sReturn = Space$(256) lRet = mciSendString("status mp3audio length", _ sReturn, Len(sReturn), 0&) ' MP3-Datei schliessen mciSendString "close mp3audio", 0, 0, 0 GetMP3Length = Val(sReturn) End Function ' Für das Umwandeln der Zeitrückgabe (Millisekunden) in ein besser ' lesbares Format (Minuten:Sekunden) können Sie zusätzlich nachfolgende ' Funktion einsetzen: ' Millisekunden in lesbares Zeitformat umwandeln Function FormatTime(ByVal lMSec As Long) _ As String Dim iMin As Integer Dim iSec As Integer iSec = Int(lMSec / 1000) iMin = Int(iSec / 60) iSec = iSec - (iMin * 60) FormatTime = Format$(iMin, "00") & ":" & _ Format$(iSec, "00") End Function -

msgbox ikaz

ID : 1554
ISLEM : msgbox ikaz
MAKRO KODU : Sub sonkezsor() soru = MsgBox("Eminmisiniz?", Buttons:=vbQuestion + vbYesNo) If soru = vbYes Then ..................... End If End Sub

msgbox la a1 e veri girme

ID : 1555
ISLEM : msgbox la a1 e veri girme
MAKRO KODU : Sub EingabeUeberInputbox() Dim wert01 As String wert01 = InputBox("Wert eingeben", "Bitte geben Sie einen Wert ein") Range("a1").Value = wert01 End Sub

msgbox'da - gün - tarih - saat gösteri

ID : 1556
ISLEM : msgbox'da - gün - tarih - saat gösteri
MAKRO KODU : Msgbox'da - Gün - Tarih - Saat gösterir Sub MsgBox() Dim WshShell Dim intAntwort As Integer Set WshShell = CreateObject("WScript.Shell") intAntwort = WshShell.Popup(WeekdayName(Weekday(Date, vbMonday)) _ & Chr(13) & _ Day(Date) & ". " & _ MonthName(Month(Date)) & " " & _ Year(Date) & Chr(13) & _ Time, 3, "www.excel.web.tr") End Sub

msgbox'da - gün - tarih - saat gösterir

ID : 1557
ISLEM : msgbox'da - gün - tarih - saat gösterir
MAKRO KODU : Sub MsgBox() Dim WshShell Dim intAntwort As Integer Set WshShell = CreateObject("WScript.Shell") intAntwort = WshShell.Popup(WeekdayName(Weekday(Date, vbMonday)) _ & Chr(13) & _ Day(Date) & ". " & _ MonthName(Month(Date)) & " " & _ Year(Date) & Chr(13) & _ Time, 3, "pir") End Sub

multipage de butonla geçiş

ID : 1558
ISLEM : multipage de butonla geçiş
MAKRO KODU : Private Sub CommandButton3_Click() MultiPage1.Value = MultiPage1.Value + 1 End Sub

multipage de sayfa seçmek

ID : 1559
ISLEM : multipage de sayfa seçmek
MAKRO KODU : Private Sub MultiPage1_Change() Select Case MultiPage1.SelectedItem.Caption Case "Page1": Sheets("Sayfa1").Select Case "Page2": Sheets("Sayfa2").Select Case "Page3": Sheets("Sayfa3").Select Case "Page4": Sheets("Sayfa4").Select End Select End Sub

multipage' e tıklayınca makro çalışması

ID : 1560
ISLEM : multipage' e tıklayınca makro çalışması
MAKRO KODU : Öncelikle Page1'in index'inin 0 ve page2'nin index'inin 1 olduğunu bilmelisiniz. Aşağıdaki kodu yazın. Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0 makro1 Case 1 makro2 End Select End Sub

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