• Web sitemizin SORU-CEVAP bölümünde dosya yüklemek ve dosya indirmek ÜCRETSİZ'dir.
    Gizlilik kapsamında, sadece site yöneticilerimizin ve üyenin kendisinin görebileceği ÜCRETLİ ÖZEL DESTEK alanımız mevcuttur.

Makale Faydalı Excel Makro kod örnekleri

Bu makalemizde, Excel makrolarına dair faydalı kod örneklerine yer verilmiştir.

Aşağıya ekleyeceğimiz kod örneklerini kullanarak daha önce hiç VBA kodlarını kullanmamış olsanız dahi, kolayca ne işe yaradığını anlayacaksınız. Tüm örnek kodlara, içeriği anlaşılacak şekilde başlık verilmiştir.
Tabi makrolara ilk adımı atıyorsanız, öncesinde kodlarımızı yapıştıracağımız VB penceresinin nasıl açılacağını bilmek gerekir.
VB penceresine, Şerit Menü -> Geliştirici sekmesinden ulaşabilirsiniz ya da kısayol olarak Alt ve F11tuşlarını kullanabilirsiniz.
Eğer menüde Geliştirici sekmesi yoksa, paniklemeyin ve buraya tıklayın.

Artık VB penceresinin nasıl açılacağını öğrendiğinize göre, boş bir Excel sayfası açıkken VB penceresine geçiş yapın ve Menü'den Insert -> Module diyerek boş bir kod alanı açarak aşağıdaki kodlarımızı denemeye başlayın.

TEMEL KODLAR

Otomatik sıra numarası ekleme


Aşağıdaki örnek kod, aktif hücrenin bulunduğu yerden itibaren aşağı doğru yazacağınız kadar sayıyı 1'den başlayarak sıralama işlevi görmektedir.
Kod:
Sub YazdığınızSayıKadarOtomatikEkleme()
Dim i As Integer
On Error GoTo Son

i = InputBox("Sayı yazın", "Bir sayı yazın")
For i = 1 To i
ActiveCell.Value = i
ActiveCell.Offset(1, 0).Activate
Next i

Son: Exit Sub
End Sub

Birden fazla sütun ekleme

Bu makroyu çalıştırdığınızda, ekrana bir giriş kutusu gösterilir ve eklemek istediğiniz sütun sayısını girmeniz yeterli olur. Sonucu inceleyin.
Kod:
Sub BirdenFazlaSütunEkle()
Dim i As Integer
Dim j As Integer

ActiveCell.EntireColumn.Select

On Error GoTo Son
i = InputBox("Eklenecek sütun sayısını girin", "Sütun Ekle")
For j = 1 To i
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightorAbove
Next j

Son: Exit Sub
End Sub

Birden fazla satır ekleme

Bu makroyu çalıştırdığınızda, ekrana bir giriş kutusu gösterilir ve eklemek istediğiniz satır sayısını girmeniz yeterli olur. Sonucu inceleyin.
Kod:
Sub BirdenFazlaSatırEkle()
Dim i As Integer
Dim j As Integer

ActiveCell.EntireRow.Select

On Error GoTo Son
i = InputBox("Eklenecek satır sayısını girin", "Satır Ekle")
For j = 1 To i
Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove
Next j

Son: Exit Sub
End Sub

Otomatik sütun genişliği

Çalışma sayfanızdaki tüm sütunların, hızlı bir şekilde otomatik olarak genişliğini ayarlar.
Kod:
Sub OtomatikSütunGenişliği()
Cells.Select Cells.EntireColumn.AutoFit
End Sub

Otomatik satır genişliği

Çalışma sayfanızdaki tüm satırlarn, hızlı bir şekilde otomatik olarak genişliğini ayarlar.
Kod:
Sub OtomatikSatırGenişliği()
Cells.Select
Cells.EntireRow.AutoFit
End Sub

Metni kaydır özelliğini iptal et

Bu kod, çalışma sayfasının tamamındaki metni kaydır özelliği uygulanmış hücrelerdeki bu özeliliği kaldırır.
Kod:
Sub MetniKaydırİptal()
Cells.Select
Selection.WrapText = False
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
End Sub

Birleştirilmiş hücreleri iptal et

Aşağıdaki kod, Excel sayfanız üzerinden yer alan birleştirilmiş hücreleri, tek bir hücre haline getirmenizi sağlar.
Kod:
Sub BirleştirilmişHücreleriİptalEt()
Selection.UnMerge
End Sub

Hesap makinesini aç

Aşağıdaki kodu kullanarak, Windows hesap makinesini açabilirsiniz.
Kod:
Sub HesapMakinesiniAç()
Application.ActivateMicrosoftApp Index:=0
End Sub

Alt Bilgi/Üst Bilgiye tarih ekleme

Çalışma sayfanızdaki üst bilgiye veya alt bilgiye tarih eklemek için bu kodu kullanabilirsiniz.
Kod:
Sub AltÜstBilgiyeTarihEkleme()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "&D"
.RightFooter = ""
End With
ActiveWindow.View = xlNormalView
End Sub

Özel Alt Bilgi/Üst Bilgi

Eğer Excel sayfalarınızdan alacağınız çıktılarda özel bir başlık kullanmak istiyorsanız, aşağıdaki kod ile bu işin üstesinden gelebilirsiniz.
Kod:
Sub ÖzelAltÜstBilgi()
Dim myText As Stringmy
Text = InputBox("Metninizi buraya girin", "Metin Girişi")
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = myText
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub

BİÇİMLENDİRME KODLARI

Bu gruptaki VBA kodları, bazı spesifik kriterler ve koşulları kullanarak, hücreleri ve veri alanlarını biçimlendirmenize yardımcı olur.

Tekrarlayan verileri vurgulama
Kod:
Sub TekrarlayanVerileriVurgulama()
Dim Alan As Range
Dim Hucre As Range
Set Alan = Selection

For Each Hucre In Alan
If WorksheetFunction.CountIf(Alan, Hucre.Value) > 1 Then
Hucre.Interior.ColorIndex = 36
End If
Next Hucre
End Sub

Aktif satırı ve sütunu vurgulama

Kodu çalıştırmanız için aşağıdaki adımları yerine getirmeniz gerekir.
  1. VBE penceresini (Alt + F11) açın.
  2. Project - VBA Project alanının, ekranın sol tarafında görüldüğünden emin olun. Görünmüyorsa, Ctrl + R kısayolu ile hızlıca açın.
  3. Çalışma kitabınızdaki, makroyu etkinleştirmek istediğiniz çalışma sayfasının adına çift tıklayın.
  4. Aşağıdaki kodu yapıştırın.
  5. VBE penceresini kapatın ya da Excel'in ön yüzüne geçin.
Herhangi bir hücreye çift tıkladığınızda, sonucu göreceksiniz.
Kod:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Alan As String

Alan = Target.Cells.Address & "," & Target.Cells.EntireColumn.Address & "," & Target.Cells.EntireRow.Address
Range(Alan).Select
End Sub

TOP 10'u vurgulama
Kod:
Sub Top10()
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 10
.Percent = False
End With
With Selection.FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

Ad Tanımlama yapılmış alanları vurgulama
Kod:
Sub AdTanımlamaYapılmışAlanlarıVurgulama()
Dim Alan As Name
Dim VurgulananAlan As Range

On Error Resume Next
For Each Alan In ActiveWorkbook.Names
Set VurgulananAlan = Alan.RefersToRange
VurgulananAlan.Interior.ColorIndex = 36
Next Alan
End Sub

X değerden büyük olanları vurgulama
Kod:
Sub XDeğerdenBüyükOlanlarıVurgulama()
Dim i As Integer
i = InputBox("Bir değer yazın", "Veri Girişi")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(31, 218, 154)
End With
End Sub

X değerden küçük olanları vurgulama
Kod:
Sub XDeğerdenKüçükOlanlarıVurgulama()
Dim i As Integer
i = InputBox("Bir değer yazın", "Veri Girişi")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLower, Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(217, 83, 79)
End With
End Sub

Negatif sayıları vurgulama
Kod:
Sub NegatifSayılarıVurgulama()
Dim Alan As Range

For Each Alan In Selection
If WorksheetFunction.IsNumber(Alan) Then
If Alan.Value < 0 Then
Alan.Font.Color = -16776961
End If
End If
Next
End Sub

Yorumları içeren Hücreleri Vurgula
Kod:
Sub YorumlarıİçerenHücreleriVurgula()
Selection.SpecialCells(xlCellTypeComments).Select
Selection.Style = "Not" 'ingilizce versiyonlar "Note" yazılır
End Sub

Hatalı hücreleri vurgulama
Kod:
Sub HatalıHücreleriVurgulama()
Dim Alan As Range
Dim i As Integer
For Each Alan In ActiveSheet.UsedRange
If WorksheetFunction.IsError(Alan) Then
i = i + 1
Alan.Style = "Kötü" 'ingilizce versiyonlar "Bad" yazılır
End If
Next Alan
MsgBox "Toplam " & i & " hatalı hücre var."
End Sub

Yanlış yazılmış kelimeleri vurgula
Kod:
Sub YanlışYazılmışKelimeleriVurgula()
Dim Alan As Range
For Each Alan In ActiveSheet.UsedRange
If Not Application.CheckSpelling(word:=Alan.Text) Then
Alan.Style = "Kötü"
End If
Next Alan
End Sub

Bir değeri vurgulama
Kod:
Sub BirDeğeriVurgulama()
Dim Alan As Range
Dim i As Integer
Dim c As Variant
c = InputBox("Vurgulanacak değeri girin")
For Each Alan In ActiveSheet.UsedRange
If Alan = c Then
Alan.Style = "Not"
i = i + 1
End If
Next Alan
End Sub

Boşluk olan hücreleri vurgulama
Kod:
Sub BoşlukOlanHücreleriVurgulama()
Dim Alan As Range
For Each Alan In ActiveSheet.UsedRange
If Alan.Value = " " Then
Alan.Style = "Not"
End If
Next Alan
End Sub

Aralıktaki maksimum değeri vurgulama
Kod:
Sub AralıktakiMaxDeğeriVurgulama()
Dim Alan As Range
For Each Alan In Selection
If Alan = WorksheetFunction.Max(Selection) Then
Alan.Style = "İyi"
End If
Next Alan
End Sub

Aralıktaki minimum değeri vurgulama
Kod:
Sub AralıktakiMinDeğeriVurgulama()
Dim Alan As Range
For Each Alan In Selection
If Alan = WorksheetFunction.Min(Selection) Then
Alan.Style = "İyi"
End If
Next Alan
End Sub

Benzersiz değerleri vurgulama
Kod:
Sub BenzersizDeğerleriVurgulama()
Dim Alan As Range
Set Alan = Selection
Alan.FormatConditions.Delete
Dim uv As UniqueValues
Set uv = Alan.FormatConditions.AddUniqueValues
uv.DupeUnique = xlUnique
uv.Interior.Color = vbGreen
End Sub

Sütunlardaki farkı vurgulama
Kod:
Sub SütunlardakiFarkıVurgulama()
Range("H7:H8,I7:I8").Select
Selection.ColumnDifferences(ActiveCell).Select
Selection.Style = "Kötü"
End Sub

Satırlardaki farkı vurgulama
Kod:
Sub SütunlardakiFarkıVurgulama()
Range("H7:H8,I7:I8").Select
Selection.RowDifferences(ActiveCell).Select
Selection.Style = "Kötü"
End Sub

YAZDIRMA KODLARI

Aşağıdaki makro örnekeri, bazı yazdırma işlemlerini otomatikleştirerek zaman kazanmanıza yardımcı olur.

Yorumları yazdırma
Kod:
Sub YorumlarıYazdır()
With ActiveSheet.PageSetup
.printComments = xlPrintSheetEnd
End With
End Sub

Seçimi yazdır
Kod:
Sub SeçimiYazdır()
ActiveSheet.Range("A1:A5").Select
Selection.PrintOut Copies:=1, Collate:=True
End Sub

Özel sayfaları yzdır
Kod:
Sub ÖzelSayfalarıYazdır()
Dim startpage As Integer
Dim endpage As Integer
startpage = InputBox("Yazdırmak istediğiniz ilk sayfanın numarasını yazınız.", "Değer girin")
If Not WorksheetFunction.IsNumber(startpage) Then
MsgBox "Geçersiz ilk sayfa numarası. Lütfen tekrar deneyin.", "Hata"
Exit Sub
End If
endpage = InputBox("Yazdırmak istediğiniz son sayfanın numarasını yazınız.", "Değer girin")
If Not WorksheetFunction.IsNumber(endpage) Then
MsgBox "Geçersiz son sayfa numarası. Lütfen tekrar deneyin.", "Hata"
Exit Sub
End If
Selection.PrintOut From:=startpage, To:=endpage, Copies:=1, Collate:=True
End Sub

ÇALIŞMA SAYFASI KODLARI

Aşağıdaki makro kodları, çalışma sayfalarını kolay bir şekilde kontrol etmenize, yönetmenize yardımcı olur.

Etkin sayfa hariç tüm sayfaları gizleme
Kod:
Sub SayfalariGizleme()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub

Tüm gizli sayfaları göster
Kod:
Sub SayfalarıGöster()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

Etkin sayfa hariç tüm sayfaları gizleme
Kod:
Sub SayfalarıSil()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
End Sub

Çalışma sayfalarını koruma
Kod:
Sub TümSayfalarıKoru()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Enter a Password.", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:=ps
Next ws
End Sub

Grafikleri yeniden boyutlandırma
Kod:
Sub GrafikleriBoyutlandır()
Dim i As Integer
For i = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(i)
.Width = 300
.Height = 200
End With
Next i
End Sub

Birden çok çalışma sayfası ekleme
Kod:
Sub ÇokluSayfaEkleme()
Dim i As Integer
i = InputBox("Eklenecek sayfa sayısını girin.", "Sayfa adeti")
Sheets.Add After:=ActiveSheet, Count:=i
End Sub

Sayfa koruma
Kod:
Sub SayfaKoruma()
ActiveSheet.Protect "Parolanız", True, True
End Sub

Korumayı kaldırma
Kod:
Sub ProtectWS()
ActiveSheet.Protect "Parolanız", True, True
End Sub

Sayfa sıralama
Kod:
Sub SayfaSıralama()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
iAnswer = MsgBox("Sayfaları Artan Düzende Sıralamak İster misiniz?" & Chr(10) & "Hayır derseniz Azalan Sıralamada sıralanır", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sayfa sıralama")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub

Formüllü hücreleri koruma
Kod:
Sub FormüllüHücreleriKoruma()
With ActiveSheet
.Unprotect
.Cells.Locked = False
.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
.Protect AllowDeletingRows:=True
End With
End Sub

Tüm Boş Çalışma Sayfalarını Sil
Kod:
Sub BoşÇalışmaSayfalarınıSil()
Dim Ws As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Ws In Application.Worksheets
If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
Ws.Delete
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Tüm satırları ve sütunları göster
Kod:
Sub SatırSütunlarıGöster()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

Her çalışma sayfasını tek bir PDF olarak kaydetme
Kod:
Sub SayfayıPDFYapma()
Dimws As Worksheet
For Each Ws In Worksheets
Ws.ExportAsFixedFormat xlTypePDF, "Klasör Adını Yazın" & Ws.Name & ".pdf"
Next Ws
End Sub

Sayfa Sonlarını devre dışı bırakma
Kod:
Sub SayfaSonlarınıDevreDışıBırakma()
Dim wb As Workbook
Dim wks As Worksheet
Application.ScreenUpdating = False
For Each wb In Application.Workbooks
For Each Sht In wb.Worksheets
Sht.DisplayPageBreaks = False
Next Sht
Next wb
Application.ScreenUpdating = True
End Sub

ÇALIŞMA KİTABI KODLARI

Aşağıdaki kodlar, çalışma kitabı işlemlerinizi kolay bir şekilde gerçekleştirmenize yardımcı olur.

Çalışma kitabının yedeğini oluşturma
Kod:
Sub DosyayıYedekle()
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.mm.yyyy") & " " & ThisWorkbook.Name
End Sub

Tüm çalışma kitaplarını kapatma
Kod:
Sub TümÇalışmaKitaplarınıKapatma()
Dim wbs As Workbook
For Each wbs In Workbooks
wbs.Close SaveChanges:=True
Next wb
End Sub

Aktif çalışma sayfasını yeni çalışma kitabına kopyalama
Kod:
Sub AktifÇalışmaSayfasınıYeniÇalışmaKitabınaKopyalama()
ThisWorkbook.ActiveSheet.Copy Before:=Workbooks.Add.Worksheets(1)
End Sub

Aktif çalışma kitabını e-posta gönderme
Kod:
Sub MailYolla()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "admin@exceldepo.com"
.Subject = "Aktif çalışma kitabının mail olarak gönderilmesi"
.Body = "Başarılı bir şekilde test edilmiştir."
.Attachments.Add ActiveWorkbook.FullName
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

E-Posta ekine çalışma kitabı ekleme
Kod:
Sub EPostaEkineÇalışmaKitabEkleme()
Application.Dialogs(xlDialogSendMail).Show
End Sub

Hoşgeldiniz mesajı ekleme
Kod:
Sub auto_open()
MsgBox "ExcelDepo.Com'a hoşgeldiniz & ziyaretiniz için teşekkürler."
End Sub

Kapanış Mesajı
Kod:
Sub auto_close()
MsgBox "Hoşçakalın! ExcelDepo.Com'u tekrar ziyaret etmeyi unutmayın."
End Sub

Açık olup kaydedilmemiş çalışma kitaplarını sayma
Kod:
Sub AçıkOlupKaydedilmemişÇalışmaKitaplarınıSayma()
Dim book As Workbook
Dim i As Integer
For Each book In Workbooks
If book.Saved = False Then
i = i + 1
End If
Next book
MsgBox i
End Sub

PİVOT TABLO KODLARI

Aşağıdaki kodlar, pivot tablolarında bazı değişiklikleri yönetmenizi ve kolay değişiklikler yapmanıza yardımcı olur.

Özet tablo Alt Toplamlarını gizleme
Kod:
Sub AltToplamlarıGizleme()
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
If pt Is Nothing Then
MsgBox "Cursor'u bir özet tablo içine yerleştirmeniz gerekir."
Exit Sub
End If
For Each pf In pt.PivotFields
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
End Sub

Özet tabloları otomatik yenileme
Kod:
Sub UpdatePivotTableRange()
Dim Data_Sheet As Worksheet
Dim Pivot_Sheet As Worksheet
Dim StartPoint As Range
Dim DataRange As Range
Dim PivotName As String
Dim NewRange As String
Dim LastCol As Long
Dim lastRow As Long

Set Data_Sheet = ThisWorkbook.Worksheets("PivotTableData3")
Set Pivot_Sheet = ThisWorkbook.Worksheets("Pivot3")

PivotName = "PivotTable2"

Data_Sheet.Activate
Set StartPoint = Data_Sheet.Range("A1")
LastCol = StartPoint.End(xlToRight).Column
DownCell = StartPoint.End(xlDown).Row
Set DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))
NewRange = Data_Sheet.Name & "!" & DataRange.Address(ReferenceStyle:=xlR1C1)

Pivot_Sheet.PivotTables(PivotName). _
ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)

Pivot_Sheet.PivotTables(PivotName).RefreshTable

Pivot_Sheet.Activate
MsgBox "Özet tablo güncellendi."
End Sub

Özet tabloları devre dışı bırak / etkinleştir
Kod:
Sub activateGetPivotData()
Application.GenerateGetPivotData = True
End Sub
Sub deactivateGetPivotData()
Application.GenerateGetPivotData = False
End Sub

GRAFİK KODLARI

Excel'deki grafikleri yönetmek ve zamandan tasarruf etmek için aşağıdaki VBA kodları kullanabilirsiniz.

Grafik türünü değiştirme
Kod:
Sub GrafikTürünüDeğiştirme()
ActiveChart.ChartType = xlColumnClustered
End Sub

Grafiği resim olarak yapıştırma
Kod:
Sub GrafiğiResimOlarakYapıştırma()
ActiveChart.ChartArea.Copy
ActiveSheet.Range("A1").Select
ActiveSheet.Pictures.Paste.Select
End Sub

Grafik başlığı ekleme
Kod:
Sub GrafikBaşlığıEkleme()
Dim i As Variant
i = InputBox("Başlık girin", "Grafik başlığı")
On Error GoTo Son
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Text = i
Son:
Exit Sub
End Sub

FORMÜL KODLARI

Aşağıdaki kodlar, Excel fonksiyonları ile oluşturduğunuz formüllerde, sıklıkla yaptığınız sonuçları kolayca hesaplamanıza yardımcı olur.

Tüm formülleri değerlere dönüştürme
Kod:
Sub DeğereDönüştürme()
Dim Alan As Range
Dim Hucre As Range
Select Case MsgBox("Formülleri değere dönüştürmek istediğinize emin misiniz?" & "Önce dosyanızı kaydetmek ister misiniz??", vbYesNoCancel, "Uyarı")
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set Alan = Selection
For Each Hucre In Alan
If Hucre.HasFormula Then
Hucre.Formula = Hucre.Value
End If
Next Hucre
End Sub

Seçili hücrelerden boşlukları kaldırma
Kod:
Sub BoşluklarıKaldırma()
Dim Alan As Range
Dim Hucre As Range
Select Case MsgBox("Formülleri değere dönüştürmek istediğinize emin misiniz?" & "Önce dosyanızı kaydetmek ister misiniz??", vbYesNoCancel, "Uyarı")
Case Is = vbYesThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set Alan = Selection
For Each Hucre In Alan
If Not IsEmpty(Hucre) Then
Hucre = Trim(Hucre)
End If
Next Hucre
End Sub

Karakter kaldırma
Kod:
Public Function KarakterKaldırma(rng As String, cnt As Long)
KarakterKaldırma = Right(rng, Len(rng) - cnt)
End Function

Derece Simgesi Ekleme
Kod:
Sub DereceSimgesiEkleme()
Dim rng As Range
For Each rng In Selection
rng.Select
If ActiveCell <> "" Then
If IsNumeric(ActiveCell.Value) Then
ActiveCell.Value = ActiveCell.Value & "°"
End If
End If
Next
End Sub

Tersten Yazdırma
Kod:
Public Function TersÇevirme(ByVal cell As Range) As String
TersÇevirme = VBA.StrReverse(cell.Value)
End Function

A1 Referans Stilini Etkinleştirme
Kod:
Sub ActivateA1()
If Application.ReferenceStyle = xlR1C1 Then
Application.ReferenceStyle = xlA1
Else
Application.ReferenceStyle = xlA1
End If
End Sub

Saat ekleme
Kod:
Sub SaatEkle()
Dim i As Integer
For i = 1 To 24
ActiveCell.FormulaR1C1 = i & ":00"
ActiveCell.NumberFormat = "[$-409]hh:mm;@"
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
End Sub

Tarihi Güne Dönüştür
Kod:
Sub TarihiGüneDönüştür()
Dim tempCell As Range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Day(tempCell)
.NumberFormat = "0"
End With
End If
Next tempCell
End Sub

Tarihi Yıl'a Dönüştür
Kod:
Sub TarihiYılaDönüştür()
Dim tempCell As Range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Year(tempCell)
.NumberFormat = "0"
End With
End If
Next tempCell
End Sub

Tarihten Saati Kaldırma
Kod:
Sub TarihtenSaatiKaldırma()
Dim Rng As Range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = VBA.Int(Rng.Value)
End If
Next
Selection.NumberFormat = "dd.mm.yyyy"
End Sub

Tarih ve Saatten Tarihi Kaldırma
Kod:
Sub TarihSaattenTarihiKaldırma()
Dim Rng As Range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = Rng.Value - VBA.Fix(Rng.Value)
End If
Next
Selection.NumberFormat = "hh:mm:ss"
End Sub

Büyük Harfe Dönüştürme
Kod:
Sub BüyükHarfeDönüştürme()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Rng)
End If
Next
End Sub

Küçük Harfe Dönüştürme
Kod:
Sub KüçükHarfeDönüştürme()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = LCase(Rng)
End If
Next
End Sub

Baş Harfleri Büyük Yapma
Kod:
Sub BaşHarfleriBüyükYapma()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value = WorksheetFunction.Proper(Rng.Value)
End If
Next
End Sub

Cümleye Dönüştürme
Kod:
Sub CümleyeDönüştürme()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng) - 1))
End If
Next Rng
End Sub

Bir karakter kaldırma
Kod:
Sub KarakterKaldırma()
Dim Rng As Range
Dim rc As String
rc = InputBox("Kaldırılacak karakteri yazın", "Birşeyler yaz")
For Each Rng In Selection
Selection.Replace What:=rc, Replacement:=""
Next
End Sub

Sayfadaki kelime sayısını sayma
Kod:
Sub KelimeSayma()
Dim WordCnt As Long
Dim rng As Range
Dim S As String
Dim N As Long
For Each rng In ActiveSheet.UsedRange.Cells
S = Application.WorksheetFunction.Trim(rng.Text)
N = 0
If S <> vbNullString Then
N = Len(S) - Len(Replace(S, " ", "")) + 1
End If
WordCnt = WordCnt + N
Next rng
MsgBox "Sayfada toplam " & Format(WordCnt, "#,##0") & " kelime var"
End Sub

Ondalık Rakamı Tamsayı Yapma
Kod:
Sub OndalıkSayıyıKaldırma()
Dim lnumber As Double
Dim lResult As Long
Dim rng As Range
For Each rng In Selection
rng.Value = Int(rng)
rng.NumberFormat = "0"
Next rng
End Sub

Seçili alanı bir sayı ile çarpma
Kod:
Sub multiplyWithNumber()
Dim rng As Range
Dim c As Integer
c = InputBox("Çarpılacak bir sayı girin", "Gerekli alan")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng * c
Else
End If
Next rng
End Sub

Seçili alana bir sayı ekleme
Kod:
Sub SayıEkleme()
Dim rng As Range
Dim i As Integer
i = InputBox("Eklenecek bir sayı girin", "Gerekli alan")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng + i
Else
End If
Next rng
End Sub

Karakök Hesaplama
Kod:
Sub KarakökHesapla()
Dim rng As Range
Dim i As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = Sqr(rng)
Else
End If
Next rng
End Sub

Küp Kök Hesaplama
Kod:
Sub KüpKökHesaplama()
Dim rng As Range
Dim i As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng ^ (1 / 3)
Else
End If
Next rng
End Sub

Negatif İşaretleri Kaldırma
Kod:
Sub Negatif İşaretleri Kaldırma()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = Abs(rng)
End If
Next rng
End Sub

Boş Hücreleri Sıfırlarla Değiştirme
Kod:
Sub BoşHücreleriSıfırlarlaDeğiştirme()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = "" Or rng = " " Then
rng.Value = "0"
Else
End If
Next rng
End Sub
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Son düzenleme:

valentino06

VIP
VIP
Kullanıcı
Versiyon
  1. Excel 2019
Sürüm
  1. 32 bit
Dil
  1. Türkçe
  2. İngilizce

Reputation:

Bahadır hocam mükemmel paylaşım çok faydalı bilgiler için çok teşekkürler.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

PriveT

İlyas
Yönetici
Site Yöneticisi
Yaş
43
Versiyon
  1. Excel 2019
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Paylaşım için teşekkürler.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mc_exrem

Yeni Üye
Kullanıcı
Versiyon
  1. Ofis 365
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Merhabalar

Çalışma Kitabının Yedeğini Oluşturma kodu yedeği dosyanın bulunduğu yere mi oluşturuyor, bir de hangi komutla oluşturuyor.

Teşekkürler. Saygılar
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

AhmetRasim

Forum Yönetimi
Yönetici
Site Yöneticisi
Versiyon
  1. Excel 2019
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Merhabalar Sn. mc_exrem;

-- ThisWorkbook.SaveCopyAs kısmındaki SaveCopyAs özelliği ile Dosyanın Kopyası oluşturulur.
-- ThisWorkbook.Path kısmındaki Path özelliği, kodların çalıştığı Excel Çalışma Kitabının bulunduğu dosya yolunu gösterir.

Bu kodu çalıştırdığınızda, kodların çalıştığı Excel Çalışma Kitabının olduğu klasöre, o günün tarihi ile bir kopyasını oluşturur.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Tabi bir de şunu belirtmek lazım.
İşlem zaten kaydedilmiş bir dosyada çalışacaktır.

Yeni (henüz kaydedilmemiş) bir excel belgesi açıp, bu kodu uygulayıp çalıştırırsanız sorun çıkacaktır.
Yeni (henüz kaydedilmemiş) belge için işlem SaveCopyAs değil SaveAs işlemi olmalıdır.

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mc_exrem

Yeni Üye
Kullanıcı
Versiyon
  1. Ofis 365
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Merhabalar Sn. mc_exrem;

-- ThisWorkbook.SaveCopyAs kısmındaki SaveCopyAs özelliği ile Dosyanın Kopyası oluşturulur.
-- ThisWorkbook.Path kısmındaki Path özelliği, kodların çalıştığı Excel Çalışma Kitabının bulunduğu dosya yolunu gösterir.

Bu kodu çalıştırdığınızda, kodların çalıştığı Excel Çalışma Kitabının olduğu klasöre, o günün tarihi ile bir kopyasını oluşturur.
bu makroyu sol üstteki kaydet tuşuyla etkinleştirmemiz mümkün mü?
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

bu makroyu sol üstteki kaydet tuşuyla etkinleştirmemiz mümkün mü?

Kodu ThisWorkbook bölümüne yapıştırın.

Böylece, aynı gün içerisinde sadece bir kopya belge olacak (aynı gün ikinci kez kaydet dediğinizde, yedek dosyanın üstüne yazılacak),
son kaydetme işleminden farklı günde KAYDET işlemi yaptığınızda ise yedek dosyanın o günün tarihini taşıyan yedeği oluşacak.

C++:
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.mm.yyyy") & "_" & ThisWorkbook.Name
End Sub

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mc_exrem

Yeni Üye
Kullanıcı
Versiyon
  1. Ofis 365
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Kodu ThisWorkbook bölümüne yapıştırın.

Böylece, aynı gün içerisinde sadece bir kopya belge olacak (aynı gün ikinci kez kaydet dediğinizde, yedek dosyanın üstüne yazılacak),
son kaydetme işleminden farklı günde KAYDET işlemi yaptığınızda ise yedek dosyanın o günün tarihini taşıyan yedeği oluşacak.

C++:
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.mm.yyyy") & "_" & ThisWorkbook.Name
End Sub

.
👏🏼👏🏼👏🏼
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

excelismail

VIP
VIP
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Çok hoşuma gitti.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Admin

Kurucu
Kurucu
Yaş
42

Reputation:

Arkadaşlar,
Excel VBA Kod Bankası | Excel Depo
linkini de ziyaret etmenizi naçizane tavsiye ederim.
Tamamen Excel VBA kodlarına yönelik özel bir modüldür ve tüm eklenen kodlara dair nasıl kullanılacağını gösteren detayları yazılıdır.
Kullanıcı gözüyle geliştirmeye yönelik önerileriniz olursa da çok sevinirim.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mc_exrem

Yeni Üye
Kullanıcı
Versiyon
  1. Ofis 365
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Kodu ThisWorkbook bölümüne yapıştırın.

Böylece, aynı gün içerisinde sadece bir kopya belge olacak (aynı gün ikinci kez kaydet dediğinizde, yedek dosyanın üstüne yazılacak),
son kaydetme işleminden farklı günde KAYDET işlemi yaptığınızda ise yedek dosyanın o günün tarihini taşıyan yedeği oluşacak.

C++:
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.mm.yyyy") & "_" & ThisWorkbook.Name
End Sub

.
tekrardan merhabalar
kodu dediğiniz gibi yaptım ama kaydet dediğimde yedek oluşturmuyor kodu çalıştır dediğimde yedeği attı. Bakabilir misiniz.


dosya ekleyemiyorum?
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Kod başlığını değiştirmişsiniz.
Kodu, cevabımda verdiğim haliyle ekleyin.

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mc_exrem

Yeni Üye
Kullanıcı
Versiyon
  1. Ofis 365
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Kod başlığını değiştirmişsiniz.
Kodu, cevabımda verdiğim haliyle ekleyin.

.
evet oldu çok teşekkür ederim.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Üst