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

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

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

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