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.- VBE penceresini (Alt + F11) açın.
- 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.
- Çalışma kitabınızdaki, makroyu etkinleştirmek istediğiniz çalışma sayfasının adına çift tıklayın.
- Aşağıdaki kodu yapıştırın.
- VBE penceresini kapatın ya da Excel'in ön yüzüne geçin.
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