Kitabın başlığını değiştirme

Sub test()
   Application.Caption = "Excelci"
ActiveWindow.Caption = "pirr"
   'Incorrect
   MsgBox Application.Caption & " " & ActiveWindow.Caption
   'Correct
   MsgBox Application.Caption
 End Sub

Excel'de çalışma kitabını otomatik kaydetme

ÇALIŞMA KİTABINI KAPATTIĞINIZDA KİTABI OTOMATİK KAYIT YAPAR VEYA YAPMAZ
Sub Auto_close()
Workbooks("Kitap1.xls").Close True 'False kaydetmeden kitabı kapar
End Sub

Excel de sayfadaki e-mail adreslerinin ayıklanması makrosu

Sub ayikla()
    For x = 1 To [a65536].End(3).Row
    d = Split(Cells(x, 1))
        For Each elem In d
            If InStr(elem, "@") Then
                a = a + 1
                Sheets("sayfa2").Cells(a, 1) = Trim(Replace(Replace(Replace(elem, ",", ""), "e-mail:", ""), Chr(160), ""))
            End If
        Next elem
    Next x
        Sheets("sayfa2").Select
End Sub

Excel de makro yazarak dosya silme

Sub sil()
    Kill "C:\xxx\xxx\a.jpg"
End Sub

Dosya arama (var mı, yok mu)

Sub dosya_ara()
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists("C:\testfile.txt")
If a = True Then
MsgBox "Bu isimde bir dosya var"
Else
MsgBox "Bu isimde bir dosya yok"
End If
End Sub

Dosya düzen çubuğuna menü ekleme silme

Modüle

Option Explicit

Sub CreateMenu()
' creates a new menu.
' can also be used to create commandbarbuttons
' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro
Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl
    RemoveMenu ' delete the menu if it already exists
    ' create a new menu on an existing commandbar (the next 6 lines)
    Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True)
    With cbMenu
        .Caption = "&My menu"
        .Tag = "MyTag"
        .BeginGroup = False
    End With
    ' or add to an existing menu (use the next line instead of the previous 6 lines)
    'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Tools-menu
    If cbMenu Is Nothing Then Exit Sub ' didn't find the menu...


    ' add menuitem to menu
    With cbMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Menu Item1"
        .OnAction = ThisWorkbook.Name & "!Macroname"
    End With


    ' add menuitem to menu
    With cbMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Menu Item2"
        .OnAction = ThisWorkbook.Name & "!Macroname"
    End With


    ' add a submenu
    Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True)
    With cbSubMenu
        .Caption = "&Submenu1"
        .Tag = "SubMenu1"
        .BeginGroup = True
    End With


    ' add menuitem to submenu (or buttons to a commandbar)
    With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Submenu Item1"
        .OnAction = ThisWorkbook.Name & "!Macroname"
        .Style = msoButtonIconAndCaption
        .FaceId = 71
        .State = msoButtonDown ' or msoButtonUp
    End With


    ' add menuitem to submenu (or buttons to a commandbar)
    With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Submenu Item2"
        .OnAction = ThisWorkbook.Name & "!Macroname"
        .Style = msoButtonIconAndCaption
        .FaceId = 72
        .Enabled = False ' or True
    End With


    ' add a submenu to the submenu
    Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True)
    With cbSubMenu
        .Caption = "&Submenu2"
        .Tag = "SubMenu2"
        .BeginGroup = True
    End With


    ' add menuitem to submenu submenu
    With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Submenu Item1"
        .OnAction = ThisWorkbook.Name & "!Macroname"
        .Style = msoButtonIconAndCaption
        .FaceId = 71
        .State = msoButtonDown ' or msoButtonUp
    End With


    ' add menuitem to submenu submenu
    With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Submenu Item2"
        .OnAction = ThisWorkbook.Name & "!Macroname"
        .Style = msoButtonIconAndCaption
        .FaceId = 72
        .Enabled = False ' or True
    End With


    ' add menuitem to menu
    With cbMenu.Controls.Add(msoControlButton, 1, , , True)
        .Caption = "&Remove this menu"
        .OnAction = ThisWorkbook.Name & "!RemoveMenu"
        .Style = msoButtonIconAndCaption
        .FaceId = 463
        .BeginGroup = True
    End With
    Set cbSubMenu = Nothing
    Set cbMenu = Nothing
End Sub

Sub RemoveMenu()
' may be automatically executed from an Auto_Close macro or a Workbook_BeforeClose eventmacro
    DeleteCustomCommandBarControl "MyTag" ' deletes the new menu
End Sub

Private Sub DeleteCustomCommandBarControl(CustomControlTag As String)
' deletes ALL occurences of commandbar controls with a tag = CustomControlTag
    On Error Resume Next
    Do
        Application.CommandBars.FindControl(, , CustomControlTag, False).Delete
    Loop Until Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing
    On Error GoTo 0
End Sub

Sub ShowHideMenu(MenuVisible As Boolean)
' may be automatically executed from an Workbook_Activate macro or a Workbook_Deactivate eventmacro
    ChangeControlVisibility "MyTag", MenuVisible ' toggles menu visibility
End Sub

Private Sub ChangeControlVisibility(CustomControlTag As String, MenuVisible As Boolean)
' toggles menu visibility
    On Error Resume Next
    Application.CommandBars.FindControl(, , CustomControlTag, False).Visible = MenuVisible
    On Error GoTo 0
End Sub

Sub Macroname()
' used by the menuitems created by the CreateMenu macro
    MsgBox "This could be your macro running!", vbInformation, ThisWorkbook.Name
End Sub

'Thisworkbook a

Private Sub Workbook_Activate()
    ShowHideMenu True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    RemoveMenu
End Sub

Private Sub Workbook_Deactivate()
    ShowHideMenu False
End Sub

Private Sub Workbook_Open()
    CreateMenu
End Sub

Excel fontları

Option Explicit

Sub GetFonts()
Dim Fonts
Dim x As Integer

x = 1

Set Fonts = Application.CommandBars.FindControl(ID:=1728)

On Error Resume Next
Do
    Cells(x + 1, 1) = Fonts.List(x)
    If Err Then Exit Do
    x = x + 1
Loop
On Error GoTo 0

Range("A1").FormulaR1C1 = "=""Font List = "" & COUNTA(R[1]C:R[" & x - 1 & "]C)"

With Range("A1")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Name = "Arial"
    .Font.FontStyle = "Bold"
    .Font.Size = 10
    .Font.ColorIndex = 5
    .Interior.ColorIndex = 15
End With

Columns("A:A").EntireColumn.AutoFit

Set Fonts = Nothing

End Sub

Excel versiyon öğrenme makro kodu

Function fGetExcelVer() As Integer
If Application.Version Like "*5*" Then
fGetExcelVer = 5
ElseIf Application.Version Like "*7*" Then
fGetExcelVer = 7
Else
fGetExcelVer = 8
End If
End Function

Sub PerVersion()
MsgBox Application.Version
Select Case Left(Application.Version, 1)
Case "5"
MsgBox "TEBRİKLER Excel 5"
Case "7"
MsgBox "TEBRİKLER Excel 7/95"
Case "8"
MsgBox "TEBRİKLER Excel 8/97"
Case Else
MsgBox "TEBRİKLER Excel- Version"
End Select
ThisWorkbook.Activate
End Sub

Excel vba sayfa koruma şifresini kaldırma

Sub SifreAc()

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer

On Error Resume Next
For i = 65 To 66
For j = 65 To 66
For k = 65 To 66
For l = 65 To 66
For m = 65 To 66
For i1 = 65 To 66
For i2 = 65 To 66
For i3 = 65 To 66
For i4 = 65 To 66
For i5 = 65 To 66
For i6 = 65 To 66
For n = 32 To 126
ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _
& Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If ActiveSheet.ProtectContents = False Then
MsgBox "One usable password is " & Chr(i) & Chr(j) _
& Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _
& Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Exit Sub
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub

Excel vba satır silme makrosu

Sub satir_sil()
Dim x, i
For i = 1 To 5  '*
For x = 2 To [D65526].End(3).Row Step 1
If Cells(x, 4) Like "*de*" Then
Rows(x).Delete
End If
Next x
Next i
End Sub

Belirlenen satırdaki ilk boş hücreyi seçme

Sub bosa_git()
Selection.SpecialCells(xlBlanks).Areas(1).Cells(1).Select
End Sub

Excel'de satır ve sütün genişliğini ayarlayan makro

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
Set rng = Columns("C:C")
If Not (Intersect(Target, rng) Is Nothing) Then
rng.ColumnWidth = 30
Else
rng.ColumnWidth = 10.71
End If
End Sub

excelde saat farkı hesaplatma makrosu

Sub fark()
Cells(3, 3) = "=NOW()"
Cells(3, 3).Select
Selection.NumberFormat = "h:mm"
Cells(3, 4) = Cells(3, 3).Value - Cells(3, 2).Value
Range("E1").Select
End Sub

excel vba saat tarih fonksiyonunu kullanımına bir örnek

LABEL KUTULARINA SAAT&TARİH EKLER
Private Sub tarih_Click()
Label1.Caption = time
Label2.Caption = Date
End Sub
'TARİH&SAAT'İ AYNI ANDA GÖSTERİR.
Private Sub Label3_Click()
Label1.Caption = Now()
End Sub

Pivot table verilerini yenileme excel vba kodu

Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.PivotTables("PivotTable4").RefreshTable
End Sub

excel vba sayfaya parola koruması koyma

Sub sifrele()
Dim sht As Worksheet
Dim MotPass
sifre = InputBox("Lütfen bir şifre yazınız", 2)

For Each sht In ActiveWorkbook.Worksheets
sht.Protect Password:=(sifre), Contents:=True, _
DrawingObjects:=True, Scenarios:=True
Next sht
End Sub

Rastgele sayı üretimi 2

 D1 hücresine üretmek istediğiniz rakamların naximum değerini 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 < Range("D2") Then
    MsgBox "D1 hücresinin değeri D2 hücresinden küçük olmamalı"
    Exit Sub
  ElseIf Range("D1").Value = "" Or Range("D2") = "" Then
    MsgBox " D1 VE D2 hücrelerine bir değer giriniz"
    Exit Sub
  End If

  Cells(1, 1).Value = Int((Range("D1") * Rnd) + 1)
  For i = 2 To Range("D2")
    Cells(i, 1).Value = Int((Range("D1") * Rnd) + 1)
    For Each bul In Range("A1:A" & Cells(i - 1, 1).Row)
      If Cells(i, 1).Value = bul.Value Then
        Cells(i, 1).Value = Int((Range("D1") * Rnd) + 1)
      End If
    Next bul
  Next i
End Sub

Rastgele sayı üretme 1

Bu kod excel kod parçacığı "B1" hücresine 0 ile 100 arasında rastgele tamsayı atar.


Sub rastgele()
    Dim sayi As Integer
    Randomize
    sayi = Int((100 * Rnd) + 1)
    Range("B1") = sayi
End Sub

Tekrarlayan kayıtları silen macro

Sub tekrarli_kayit_sil()
Cells.Sort Key1:=Range("A1")
toplam_satir = ActiveSheet.UsedRange.Rows.Count
sayac = 1
For Row = toplam_satir To 2 Step -1
  If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then
     Rows(Row).Delete
sayac = sayac + 1
End If
Next Row
End Sub

excel macro ile not defterini açma

Sub notpad()
Call Shell("notepad.exe.", 1)
End Sub

Combobox'tan textbox'lara veri aktarma

Private Sub ComboBox1_Click()
    TextBox1 = ComboBox1.Column(0)
    TextBox2 = ComboBox1.Column(1)
    TextBox3 = ComboBox1.Column(2)

End Sub
Private Sub UserForm_Activate()
With UserForm1.ComboBox1
    .AddItem "kitap"
    .AddItem "kalem"
    .AddItem "silgi"
   End With
End Sub

Excel'de basit bir hesap makinası

Bunun için formunuza 3 adet textbox 4 adet option nesnesi yerleştirmeniz gerekiyor.1. textbox birinci degeri almamıza 2. textbox  ikinci değeri almamıza 3.textbox ise işlem sonucunu göstermemize yarıyacak.Option nesneleride hangi işlemi yapacağımızı seçmemize yarayacak.



Private Sub Command1_Click()
Dim sayı1, sayı2, sonuc As integer
deger1 = Val(Text1.Text)
deger2 = Val(Text2.Text)
If Option1 = True Then sonuç = deger1 + deger2
If Option2 = True Then sonuç = deger1 - deger2
If Option3 = True Then sonuç = deger1 * deger2
If Option4 = True Then sonuç = deger1 /  deger2
Text3.Text = Str(sonuc)
End Sub

Bir sütundaki boşlukları silen macro

Bu excel makrosu "A" sütunundaki değer içermeyen satırları bulur ve siler.

Sub bosluksil()
For a = 1 To Sheets.Count
satir= Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Row
sutun = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Column
For b = satir To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Rows(b)) = 0 Then Sheets(a).Rows(b).Delete
Next
For c = sutun To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Columns(c)) = 0 Then Sheets(a).Columns(c).Delete
Next
Next
End Sub

istenilen hücreye istenilen yazı yazılınca makroyu çalıştıran kod

Bu excel makrosunda A sütununa "hoop" yazınca Test fonksiyonu çağrılıyor.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If Target = "hoop" Then Call Test
End Sub
Sub Test()
    MsgBox "Biri Benimi Çağırdı:)", vbInformation
End Sub

İstenilen sıklıkta kitabı kaydetme makrosu EXCEL-VBA

Bu örnekte kaydetme süresi 10 dakikada birdir.


Sub auto_open()
Application.OnTime Now + TimeValue("00:10:00"), "Kayıt"
End Sub

Sub Kayıt()
ActiveWorkbook.Save
MsgBox "Kitap Kaydedildi"
Call auto_open
End Sub

Bir Listbox'tan başka bir Listbox'a veri taşıma

Private Sub UserForm_Initialize()
    ListBox1.RowSource = "A1:A" & Cells(65536, 1).End(xlUp).Row
    ListBox1.ListStyle = fmListStyleOption
    ListBox1.MultiSelect = fmMultiSelectMulti
End Sub
'
Private Sub CommandButton1_Click()
    ListBox2.Clear
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            ListBox2.AddItem ListBox1.List(i)
        End If
    Next
End Sub

Excel macro ile yeni bir çalışma sayfası açma ve isim verme

Sub SayfaEkle()
    ThisWorkbook.Sheets.Add
    Sheets(ActiveSheet.Name).Name =sheets("sayfa_adi"). [a1].value
End Sub

Bilgisayarda yüklü yazıcı olup olmadığını kontrol eden excel makrosu

Private Sub UserForm_Activate()
On Local Error GoTo hata
Show
Print "kağıt kaynağı"; Printer.PaperBin
Print "renk modu"; Printer.ColorMode
Print "kopya sayısı"; Printer.Copies
Print "Yazıcının ismi"; Printer.DeviceName
Print "sürücü"; Printer.DriverName
Print "çift yönlü yazma"; Printer.Duplex
Print "yataylık-dikeylik"; Printer.Orientation
Print "sayfa boyutu"; Printer.PaperSize
Print "kullanılan port"; Printer.Port
Print "basım kalitesi"; Printer.PrintQuality
Print "yazıcı varsayılan mı"; Printer.TrackDefault
Print "ölçekleme"; Printer.Zoom
hata:
MsgBox ("yüklü bir yazıcı yok veya yazınız açık değil")
End Sub

Combobox'a ayları yazan excel macro kodu

Private Sub UserForm_Initialize()
Dim i%
Dim TMP$
    ComboBox1.Clear
    For i = 1 To 12
        TMP = Format(DateSerial(2004, i, 1), "mmmm")
        ComboBox1.AddItem TMP
    Next i
    ComboBox1.ListIndex = 0
End Sub