07 Şubat 2019 06 Ağustos 2021 1734

Faydalı Excel Makro Kod Örnekleri

Faydalı Excel Makro kod örnekleri isimli bu yazımızda, işinize yarayacak bir çok Excel makrosunu tek bir içerikte bulabilirsiniz.

Faydalı Excel VBA Kodları

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 F11 tuş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.
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.
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.
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.
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.
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.
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.
Sub BirleştirilmişHücreleriİptalEt()
Selection.UnMerge
End Sub

Hesap makinesini aç

Aşağıdaki kodu kullanarak, Windows hesap makinesini açabilirsiniz.
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.
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.
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

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.
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

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

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

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

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

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

Sub YorumlarıİçerenHücreleriVurgula()
Selection.SpecialCells(xlCellTypeComments).Select
Selection.Style = "Not" 'ingilizce versiyonlar "Note" yazılır
End Sub

Hatalı hücreleri vurgulama

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

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

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

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

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

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

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

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

Satırlardaki farkı vurgulama

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

Sub YorumlarıYazdır()
With ActiveSheet.PageSetup
 .printComments = xlPrintSheetEnd
End With
End Sub

Seçimi yazdır

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

Özel sayfaları yzdır

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

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

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

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

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

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

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

Sub SayfaKoruma()
ActiveSheet.Protect "Parolanız", True, True
End Sub

Korumayı kaldırma

Sub ProtectWS()
ActiveSheet.Protect "Parolanız", True, True
End Sub

Sayfa sıralama

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

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

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

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

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

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

Sub DosyayıYedekle()
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "" & Format(Date, "dd.mm.yyyy") & " " & ThisWorkbook.Name
End Sub

Tüm çalışma kitaplarını kapatma

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

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

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

Sub EPostaEkineÇalışmaKitabEkleme()
Application.Dialogs(xlDialogSendMail).Show
End Sub

Hoşgeldiniz mesajı ekleme

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

Kapanış Mesajı

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

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

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

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

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

Sub GrafikTürünüDeğiştirme()
ActiveChart.ChartType = xlColumnClustered
End Sub

Grafiği resim olarak yapıştırma

Sub GrafiğiResimOlarakYapıştırma()
ActiveChart.ChartArea.Copy
ActiveSheet.Range("A1").Select
ActiveSheet.Pictures.Paste.Select
End Sub

Grafik başlığı ekleme

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

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

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

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

Derece Simgesi Ekleme

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

Public Function TersÇevirme(ByVal cell As Range) As String
TersÇevirme = VBA.StrReverse(cell.Value)
End Function

A1 Referans Stilini Etkinleştirme

Sub ActivateA1()
If Application.ReferenceStyle = xlR1C1 Then
 Application.ReferenceStyle = xlA1
Else
 Application.ReferenceStyle = xlA1
End If
End Sub

Saat ekleme

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Makale Serileri

Makale Arşivi
Backlink Reklam Bu alanda 50 karakterlik açıklama ile web sitenize ait Backlink Reklam yayınlayabilirsiniz.
Yükleniyor...