VBA Örnekleriyle Biçimlendirme Yazdırma ve Sayfaları Yönetme

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

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

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

Sub OtomatikSütunGenişliği()
Cells.Select Cells.EntireColumn.AutoFit
End Sub

Sub OtomatikSatırGenişliği()
Cells.Select
Cells.EntireRow.AutoFit
End Sub

Sub MetniKaydırİptal()
Cells.Select
Selection.WrapText = False
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
End Sub

Sub BirleştirilmişHücreleriİptalEt()
Selection.UnMerge
End Sub

Sub HesapMakinesiniAç()
Application.ActivateMicrosoftApp Index:=0
End Sub

Sub AltÜstBilgiyeTarihEkleme()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "&D"
.RightFooter = ""
End With
ActiveWindow.View = xlNormalView
End Sub

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Sub SayfalarıGöster()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

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

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

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

Sub ÇokluSayfaEkleme()
Dim i As Integer
i = InputBox("Eklenecek sayfa sayısını girin.", "Sayfa adeti")
Sheets.Add After:=ActiveSheet, Count:=i
End Sub

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

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

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

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

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

Sub SatırSütunlarıGöster()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

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

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

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

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

Sub AktifÇalışmaSayfasınıYeniÇalışmaKitabınaKopyalama()
ThisWorkbook.ActiveSheet.Copy Before:=Workbooks.Add.Worksheets(1)
End Sub

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

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

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

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

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

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

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

Sub activateGetPivotData()
Application.GenerateGetPivotData = True
End Sub
Sub deactivateGetPivotData()
Application.GenerateGetPivotData = False
End Sub

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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