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


kök dosya göster

ID : 1381
ISLEM : kök dosya göster
MAKRO KODU : Sub Kök_Dosya_Göster() Dim ds, d, s Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive("C:\") s = d.RootFolder MsgBox s End Sub

köprü ekle penceresi

ID : 1382
ISLEM : köprü ekle penceresi
MAKRO KODU : Sub Dialog_39() Application.Dialogs(xlDialogInsertHyperlink).Show End Sub

köprüleri silmek için

ID : 1383
ISLEM : köprüleri silmek için
MAKRO KODU : Sub KopruSil() Range("A:A").Select Selection.Hyperlinks.Delete Range("A1").Select End Sub

kritere uyanları c sütununda (c2den itibaren) bulup tüm satırları ile birlikte siler(kriter combobox)

ID : 1384
ISLEM : kritere uyanları c sütununda (c2den itibaren) bulup tüm satırları ile birlikte siler(kriter combobox)
MAKRO KODU : For x = Cells(65536, 3).End(xlUp).Row To 2 Step -1 If Cells(x, 3) = ComboBox1.Text Then Rows(x).Delete Next

kullanıcı adı ve parola eklemek

ID : 1385
ISLEM : kullanıcı adı ve parola eklemek
MAKRO KODU : ThisWorkbook" kısmına yazın Private Sub workbook_open() Application.Visible = False UserForm1.Show End Sub 'Dosyanıza ekleyeceğiniz Userforma bir CommandButton ve iki Textbox yerleştirin ve aşağıdaki kodu Userformun kod kısmına girin Private Sub CommandButton1_Click() If TextBox1.Value = "Ali" Or TextBox1.Value = "Veli" Then goto Kontrol2 Else Unload UserForm1 MsgBox "Üzgünüm girdiğiniz kullanıcı adı hatalı.", vbCritical, "HATA" ActiveWorkbook.Close 0 Exit Sub EndIf Kontrol2: If TextBox2.Value = "123" Or TextBox2.Value = "456" Then MsgBox "Programa girişiniz onaylanmıştır.", vbInformation Unload Me Application.Visible = True Else Unload UserForm1 MsgBox "Üzgünüm girdiğiniz parola hatalı.", vbCritical, "HATA" ActiveWorkbook.Close 0 Exit Sub EndIf End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode 1 Then Cancel = True End Sub 'Ayrıca Textbox2'nin Properties kısmında bulunan "PasswordChar" bölümüne "*" (yıldız) işareti koyarsanız girilen parola ekranda "*****" şeklinde görünecektir. -

kullanıcı adı ve pc adını öğrenme

ID : 1386
ISLEM : kullanıcı adı ve pc adını öğrenme
MAKRO KODU : Private Declare Function GCN Lib "kernel32" Alias "GetComputerNameA" (ByVal myPara As String, myLen As Long) As Long Private Declare Function GUN Lib "advapi32.dll" Alias "GetUserNameA" (ByVal myPara As String, myLen As Long) As Long '******************************************************* 'Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long 'Private Declare Function GetUserNameA Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long Public Function ActiveUserName() As String Dim AUN As String * 100 Dim AunLen As Byte AunLen = 100 If GUN(AUN, Len(AUN)) Then ActiveUserName = Left(AUN, AunLen) Else ActiveUserName = "User can not be Identified" End If End Function Public Function ActiveComputerName() As String Dim ACN As String * 100 Dim AcnLen As Byte AcnLen = 100 If GCN(ACN, Len(ACN)) Then ActiveComputerName = Left(ACN, AcnLen) Else ActiveComputerName = "User can not be Identified" End If End Function Sub wer_und_was_bin_ich() Dim Qe As Byte MsgBox ("Mein Rechner heisst" & ActiveComputerName) MsgBox ("Aktuell angemeldeter User ist: " & ActiveUserName) End Sub

kullanıcı adını bulan fonksiyon

ID : 1387
ISLEM : kullanıcı adını bulan fonksiyon
MAKRO KODU : Declare Function GetUserName Lib "advapi32.dll" _ Alias "GetUserNameA" (ByVal lpBuffer As String, _ nSize As Long) As Long Sub ShowUserName() Dim Buffer As String * 100 Dim BuffLen As Long BuffLen = 100 GetUserName Buffer, BuffLen MsgBox Left(Buffer, BuffLen - 1) End Sub

kullanıcı kitabının kapatılması

ID : 1388
ISLEM : kullanıcı kitabının kapatılması
MAKRO KODU : Option Explicit Sub CloseUserBooks() Dim objWB As Workbook, arrSysBooks arrSysBooks = Array(ThisWorkbook.Name, _ "SYS01F.XLS", "SYS01S.XLS", _ "SYS01M.XLS", "SYS01D.XLS") 'These books can be open. With Application .DisplayAlerts = True 'Make sure the user has a chance to save! For Each objWB In Workbooks 'Loop through the Workbook collection. If IsError(.Match(objWB.Name, arrSysBooks, 0)) Then 'Not in the array? MsgBox "Your workbook " & objWB.Name & " must be closed before the system can start.", 0, "The Fortress" objWB.Close End If Next End With End Sub

kullanıcı tanımlı not fonksiyonu

ID : 1389
ISLEM : kullanıcı tanımlı not fonksiyonu
MAKRO KODU : Function Puan(a) If a > 100 Then Puan = "Notun 100 den büyük olduğuna emin misiniz?" If a = "d" Then Puan = "F1" If a = "g" Then Puan = "F2" If a = 0 And a -

kullanici tanimli foksiyon

ID : 1390
ISLEM : kullanici tanimli foksiyon
MAKRO KODU : Function Sutun2(a As String) As Integer If LCase(a) = LCase("a") Then Sutun2 = 1 End Function

kullanici tanimli(sayfa sayisi)

ID : 1391
ISLEM : kullanici tanimli(sayfa sayisi)
MAKRO KODU : Function SayfaSec(Hucre As Range) As String Select Case Range("B1") Case 0 SayfaSec = "Sayfa boş" Case 1 To 51 SayfaSec = Sheets(1).Name Case 52 To 101 SayfaSec = Sheets(2).Name '...... '.... '... End Select End Function Veya normal fonksiyonlar ile; ="Sayfa " & nsat(B1/50)

kullanilan xl turkce, ingilizce ..... veya ne ?

ID : 1392
ISLEM : kullanilan xl turkce, ingilizce ..... veya ne ?
MAKRO KODU : Sub Test() Dim MyLang As Long MyLang = Application.LanguageSettings.LanguageID(msoLanguageIDInstall) MsgBox GetLang(MyLang) End Sub ' Function GetLang(ID As Long) As String Select Case ID Case msoLanguageIDEnglishUS GetLang = "XL - Ingilizce" Case msoLanguageIDTurkish GetLang = "XL - Turkce" Case msoLanguageIDRussian GetLang = "XL - Rusca" Case msoLanguageIDFrench GetLang = "XL - Fransizca" Case msoLanguageIDDutch GetLang = "XL - Almanca" Case msoLanguageIDSpanish GetLang = "XL - Ispanyolca" Case msoLanguageIDItalian GetLang = "XL - Italyanca" Case Else GetLang = "XL - Belirsiz" End Select End Function

kuruşlari hesaplama

ID : 1393
ISLEM : kuruşlari hesaplama
MAKRO KODU : On Error Resume Next a = Round(TextBox3, 2) a = WorksheetFunction.Substitute(a, ",", ".") b = Round(TextBox4, 2) b = WorksheetFunction.Substitute(b, ",", ".") c = Round(TextBox5, 2) c = WorksheetFunction.Substitute(c, ",", ".") y = Round(TextBox2, 2) y = WorksheetFunction.Substitute(y, ",", ".") z = (Val(a) + Val(b) + Val(c)) - Val(y) z = WorksheetFunction.Substitute(z, ".", ",") TextBox1 = z

küsuratlı bir parasal tutarın ytl ve ykr kısımlarını ayrı hücrelere yazdırma

ID : 1394
ISLEM : küsuratlı bir parasal tutarın ytl ve ykr kısımlarını ayrı hücrelere yazdırma
MAKRO KODU : B1 hücresine girilecek formül; =TAMSAYI(A1) C1 hücresine girilecek formül; =(A1-TAMSAYI(A1))*100

label de dikey yazı

ID : 1395
ISLEM : label de dikey yazı
MAKRO KODU : Private Sub UserForm_Initialize() Dim Metin As String Dim byt As Byte Label1.Caption = "Süleyman" For byt = 1 To Len(Label1) Metin = Metin & Mid(Label1, byt, 1) & Chr(13) Next byt Label1 = Metin End Sub

label de tarih ve saat yazdırma

ID : 1396
ISLEM : label de tarih ve saat yazdırma
MAKRO KODU : Private Sub UserForm_Initialize() Label1.Caption = Format(Now, "dddd d mmmm yyyy hh:mm:ss") End Sub

label lerde ortalama alma

ID : 1397
ISLEM : label lerde ortalama alma
MAKRO KODU : Label3 = Format((Val(Label1) + Val(Label2)) / 2, "0.00")

label türetme

ID : 1398
ISLEM : label türetme
MAKRO KODU : Private Sub UserForm_Initialize() Dim NewLabel As Control Me.Width = 600 Me.Height = 300 TopPos = 4 For j = 1 To 5 TopPos = TopPos + 20 LeftPos = 10 For i = 1 To 10 Set NewLabel = Controls.Add("Forms.label.1") With NewLabel .Width = 50 .Caption = "Test" & i & " - " & j .Height = 15 .Left = LeftPos + .Width .Top = TopPos .Tag = i .AutoSize = True .Visible = True End With LeftPos = LeftPos + NewLabel.Width + 15 Next i Next j End Sub

label1 ve label2 de rakamlar var.ben label1 ve label2 deki rakamlarin ortalamasini label3 te almak istiyorum

ID : 1399
ISLEM : label1 ve label2 de rakamlar var.ben label1 ve label2 deki rakamlarin ortalamasini label3 te almak istiyorum
MAKRO KODU : Label1 ve Label2'e değerleri aktardığın kodun/prosedurun sonuna aşağıdakini ilave et; Kod: Label3 = Format((Val(Label1) + Val(Label2)) / 2, "0.00")

label'a istenilen sayfa ve hücreden değer almak

ID : 1400
ISLEM : label'a istenilen sayfa ve hücreden değer almak
MAKRO KODU : Private Sub UserForm_Initialize() UserForm1.Label1.Caption = Worksheets("Sayfa1").Range("A" & ActiveCell.Row) End Sub

labelde tarih formatı

ID : 1401
ISLEM : labelde tarih formatı
MAKRO KODU : Private Sub UserForm_Initialize() Label1.Caption = Format(Now, "dddd d mmmm yyyy hh:mm:ss") End Sub

label'de tarih ve saat

ID : 1402
ISLEM : label'de tarih ve saat
MAKRO KODU : Label1:Captioni = Now

labele tiklayinca açiklama çikar

ID : 1403
ISLEM : labele tiklayinca açiklama çikar
MAKRO KODU : Private Sub Label1_Click() Label1.Caption = "Programmer pir" End Sub

labeller de toplama, ortalama alma

ID : 1404
ISLEM : labeller de toplama, ortalama alma
MAKRO KODU : Label3 = Format((Val(Label1) + Val(Label2)) / 2, "0.00")

link koleksiyon

ID : 1405
ISLEM : link koleksiyon
MAKRO KODU : Sub ColorLinks() Dim myLnk As Hyperlink 'Dim wks As Worksheet ' For Each wks In ActiveWorkbook.Worksheets 'For Each myLnk In wks.Hyperlinks For Each myLnk In ActiveSheet.Hyperlinks 'MsgBox myLnk.Parent.Address & vbLf _ & myLnk.Parent.Parent.Name Range(myLnk.Parent.Address).Interior.ColorIndex = 34 Next myLnk ' Next wks End Sub

lisans programı

ID : 1406
ISLEM : lisans programı
MAKRO KODU : Option Explicit Declare Function ShellAbout Lib "shell32.dll" _ Alias "ShellAboutA" ( _ ByVal hWnd As Long, _ ByVal szApp As String, _ ByVal szOtherStuff As String, _ ByVal hIcon As Long) As Long Declare Function GetActiveWindow Lib "user32" () As Long '// Define your message constants here Const strApp As String = "My Programe" Const strMyDetails As String = " Ivan F Moala, 3 Sept, 2001" Sub About() Dim hWnd As Long Dim x As Long hWnd = GetActiveWindow() x = ShellAbout(hWnd, strApp, Chr(13) & Chr(169) & strMyDetails _ & Chr(13), 0) End Sub

listbox & textbox da veri görme

ID : 1407
ISLEM : listbox & textbox da veri görme
MAKRO KODU : BU KOD LİSTBOX'A YAZILACAK Private Sub ListBox1_Change() Dim sira sira = "veri!b$" & ListBox1.ListIndex + 1& veri.textbox1.ControlSource = sira End Sub BU KOD LİSTBOX' AYAZILACAK Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Select Case KeyCode Case vbKeyEscape veri.Hide End Select End Sub BU KOD TEXTBOX'A YAZILACAK Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Select Case KeyCode Case vbKeyEscape veri.Hide End Select End Sub

listbox a dakileri listeler a ya göre b dekini textboxta listele command butonla sil

ID : 1408
ISLEM : listbox a dakileri listeler a ya göre b dekini textboxta listele command butonla sil
MAKRO KODU : Private Sub CommandButton1_Click() For X = 1 To Sheets("sayfa1").[A65536].End(3).Row If Left(Sheets("sayfa1").Cells(X, 1), 100) = TextBox1.Value Then Sheets("sayfa1").Rows(X).Delete MsgBox "SİLİNDİ" TextBox1.SetFocus End If Next UserForm_Activate End Sub Private Sub ListBox1_Change() X = ListBox1.ListIndex TextBox1.Text = Sheets("SAYFA1").Cells(X + 1, 1) End Sub Private Sub UserForm_Activate() For X = 1 To Sheets("SAYFA1").[A65536].End(3).Row c = c + 1 ListBox1.AddItem ListBox1.List(c - 1, 0) = Sheets("SAYFA1").Cells(X, 1) Next End Sub

listbox a dan veri alır, tıklayınca textbox b dekini yazar

ID : 1409
ISLEM : listbox a dan veri alır, tıklayınca textbox b dekini yazar
MAKRO KODU : Private Sub TextBox1_Change() Dim MyRange As Range Dim noA As Integer ListBox1.Clear noA = WorksheetFunction.CountA(Sheets("Sayfa1").Range("A:A")) For Each MyRange In Sheets("Sayfa1").Range("A1:A" & noA) If Left(LCase(MyRange), Len(TextBox1)) = LCase(TextBox1) Then ListBox1.AddItem (MyRange) Next End Sub Private Sub ListBox1_Click() Dim x As Integer x = Sheets("Sayfa1").Range("A:A").Cells.Find(what:=ListBox1, LookIn:=xlValues).Row TextBox1.Value = ListBox1 TextBox2 = Sheets("Sayfa1").Cells(x, 2) End Sub

listbox a for döngüsü ile additem ekleme

ID : 1410
ISLEM : listbox a for döngüsü ile additem ekleme
MAKRO KODU : Private Sub CommandButton1_Click() Dim Freezer As New FreezeForm Freezer.Freeze Me Dim I As Integer For I = 1 To 1000 ListBox1.AddItem "Item " & I DoEvents Next I End Sub

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