Faydalı Excel Makro kod örnekleri


İnceleme Beğeni Favori Değerlendirme Ortalama Puan Yıldız Sayısı
237 0 0 0 0
Reklam Alanı
Türkiye'nin en popüler Excel Portalındaki içeriklerin en başında reklamınızın yayınlanmasını ister misiniz?
Reklam vermek istiyorum
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 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


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

Daha önce yorum yapılmamış!

Bir Excel sayfası üzerinde aynı içeriği temsil eden sütunlara ait ilk satırın üzerindeki bir satıra, bu sütunları kapsayacak hücreleri birleştirip başlık ataması yaptığımız olmuştur. Kullandığınız şablonlar veritabanı niteliğinde olmayan form, raporlamalarınıza görsellik katması için bu uygulamayı tavsiye ederim.

Ama veriler sadece veritabanı niteliğinde ise, hücre birleştirmeden kaçınmalısınız. Karşınıza çıkabilecek bazı problemlerin neler olduğuna dair buradaki yazıya göz atabilirsiniz.

Peki, veritabanı olarak kullandığınız bir sayfada, atayacağınız başlığı hücre birleştirme yapmadan ortalayabilir misiniz?

örneğin A2 ve C2 aralığınızda, Sicil, Adı, Soyadı şeklinde 3 sütundan oluşan verileriniz var. Siz A1:C1 aralığına "Personel Bilgileri" şeklinde bir başlık yazıp, bunu hücre birleştirme yapmadan yapacaksınız.
Bunun için:
  1. A1:C1 aralığını seçin.
  2. Farenin sağ tuşuna basın ve Hücreleri Biçimlendir'i seçin.
  3. Metin Hizalama seçeneklerinden, Yatay seçeneğinin altındaki listeyi tıklayın.
  4. Açılan listeden, Seçim Arasında Ortala seçip Tamam'a tıklayın.
Sonuç aşağıdaki gibi olacaktır.



Hücre Birleştirilmedi ama ortalama yapıldı.

İLGİ ÇEKİCİ İÇERİKLER
İçerik Adı Ekleyen Tarih Tür
Haftalık Devamsızlık Durum Çizelgesi Feyzullah 05 Ekim 2019 dosya
Geometrik Animasyon - 49 52779 27 Ekim 2019 dosya
Geometrik Dizayn - 32 52779 28 Ekim 2019 dosya
Atanh Formülü Örnekleri admin 08 Eylül 2020 dosya
Koşullu Biçimlendirme | Artış Aritmetik Değilse Biçimlendir cakarem 23 Eylül 2019 dosya
Yükleniyor...