Excel Macro Kod Arşivi

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

2010-12-30T08:23:00.001-08:00

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

2010-12-30T08:22:00.001-08:00

Ç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

2010-12-29T11:41:00.001-08:00

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

2010-12-29T11:39:00.000-08:00

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

Dosya arama (var mı, yok mu)

2010-12-29T11:37:00.001-08:00

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

2010-12-29T11:36:00.000-08:00

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ı

2010-12-29T11:34:00.001-08:00

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

2010-12-29T11:32:00.000-08:00

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

2010-12-29T11:30:00.000-08:00

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

2010-12-29T11:28:00.000-08:00

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

2010-12-29T11:25:00.000-08:00

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

2010-12-29T11:23:00.001-08:00

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

2010-12-29T11:21:00.000-08:00

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

2010-12-29T11:19:00.000-08:00

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

2010-12-29T11:17:00.000-08:00

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

excel vba sayfaya parola koruması koyma

2010-12-29T09:12:00.000-08:00

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

2010-12-29T09:01:00.000-08:00

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

2010-12-29T08:54:00.000-08:00

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

2010-12-29T08:43:00.000-08:00

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

2010-12-29T08:37:00.000-08:00

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

Combobox'tan textbox'lara veri aktarma

2010-12-29T08:35:00.000-08:00

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ı

2010-12-29T08:18:00.000-08:00

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

2010-12-29T07:47:00.000-08:00

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

2010-12-29T07:39:00.000-08:00

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

2010-12-29T07:31:00.000-08:00

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