Excel'le Adım Adım Program Yazma

Aktif satırın hepsini seçer


Sub ZeilenAuswahl()
  Selection.EntireRow.Select
End Sub

Aktif satırın herhangi bir sütununda bir satır bile dolu olsa silmez (Satırda boşlukları aldırma)

Sub DeleteBlankRowsEvenFaster()
    Set myrange = Range("B4:I31")
    Set blanks = myrange.SpecialCells(xlCellTypeBlanks)
    For Each area In blanks.Areas
        If area.Columns.Count = myrange.Columns.Count Then
            n = n + 1
            If n = 1 Then
                Set delrange = area.EntireRow
            Else
                Set delrange = Union(delrange, area.EntireRow)
            End If
        End If
    Next area
    delrange.Delete
End Sub

Aktif satırın herhangi bir sütununda bir satır bile dolu olsa silmez(Satırda boşlukları aldırma) 2

Sub DeleteBlankRows()
    Set myrange = Range("B4:I31")
    Set blanks = myrange.SpecialCells(xlCellTypeBlanks)
    For Each area In blanks.Areas
        If area.Columns.Count = myrange.Columns.Count Then
            area.EntireRow.Delete
        End If
    Next area
End Sub

Aktif sayfa haricinde tüm sayfaları siler

 Sub DeleteSheets()
           Application.DisplayAlerts = False
            For Each Sheet In Worksheets
                  If Sheet.Name <> ActiveSheet.Name Then Sheet.Delete
            Next
            Application.DisplayAlerts = True
      End If
End Sub

Aktif sayfa ismini değiştirme

Sub ArbeitsblattUmbenennen()
  Activesheet.Name="Yeni sayfa" End Sub

Aktif sayfa ve hedef hücrelerde saat formatı


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim TimeStr As String

On Error GoTo EndMacro
If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
    Exit Sub
End If
If Target.Cells.Count > 1 Then
    Exit Sub
End If
If Target.Value = "" Then
    Exit Sub
End If

Application.EnableEvents = False
With Target
If .HasFormula = False Then
    Select Case Len(.Value)
        Case 1 ' e.g., 1 = 00:01 AM
            TimeStr = "00:0" & .Value
        Case 2 ' e.g., 12 = 00:12 AM
            TimeStr = "00:" & .Value
        Case 3 ' e.g., 735 = 7:35 AM
            TimeStr = Left(.Value, 1) & ":" & _
            Right(.Value, 2)
        Case 4 ' e.g., 1234 = 12:34
            TimeStr = Left(.Value, 2) & ":" & _
            Right(.Value, 2)
        Case 5 ' e.g., 12345 = 1:23:45 NOT 12:03:45
            TimeStr = Left(.Value, 1) & ":" & _
            Mid(.Value, 2, 2) & ":" & Right(.Value, 2)
        Case 6 ' e.g., 123456 = 12:34:56
            TimeStr = Left(.Value, 2) & ":" & _
            Mid(.Value, 3, 2) & ":" & Right(.Value, 2)
        Case Else
            Err.Raise 0
    End Select
    .Value = TimeValue(TimeStr)
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "You did not enter a valid time"
Application.EnableEvents = True
End Sub

Aktif sayfa ve hedef hücrelerde tarih formatı

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim DateStr As String

On Error GoTo EndMacro
If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
    Exit Sub
End If
If Target.Cells.Count > 1 Then
    Exit Sub
End If
If Target.Value = "" Then
    Exit Sub
End If

Application.EnableEvents = False
With Target
If .HasFormula = False Then
    Select Case Len(.Formula)
        Case 4 ' e.g., 9298 = 2-Sep-1998
            DateStr = Left(.Formula, 1) & "/" & _
            Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
        Case 5 ' e.g., 11298 = 12-Jan-1998 NOT 2-Nov-1998
            DateStr = Left(.Formula, 1) & "/" & _
                Mid(.Formula, 2, 2) & "/" & Right(.Formula, 2)
        Case 6 ' e.g., 090298 = 2-Sep-1998
            DateStr = Left(.Formula, 2) & "/" & _
                Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
        Case 7 ' e.g., 1231998 = 23-Jan-1998 NOT 3-Dec-1998
            DateStr = Left(.Formula, 1) & "/" & _
                Mid(.Formula, 2, 2) & "/" & Right(.Formula, 4)
        Case 8 ' e.g., 09021998 = 2-Sep-1998
            DateStr = Left(.Formula, 2) & "/" & _
                Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
        Case Else
            Err.Raise 0
    End Select
    .Formula = DateValue(DateStr)
End If

End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "You did not enter a valid date."
Application.EnableEvents = True
End Sub

Aktif sayfa ve hücreden itibaren tüm sayfaların isimlerini yazar ve sayfalara link ekler

Sub Tabellennamen_auflisten()
'Sisto Salera 24.06.2003
'Melanie Breden 25.06.2003
Dim i       As Integer
Dim myRange As Range

Set myRange = ActiveCell
myRange.Resize(Worksheets.Count).Select

If (MsgBox("ACHTUNG: Der markierte Bereich wird überschrieben !" & vbCrLf & _
    Chr(13) & "                         Trotzdem fortfahren ?", vbYesNo)) _
    <> vbYes Then Exit Sub

For i = 1 To Worksheets.Count
    With myRange.Cells(i)
        .Value = Worksheets(i).Name
        .Hyperlinks.Add _
            Anchor:=myRange.Cells(i), _
            Address:="", _
            SubAddress:=.Value & "!" & .Address, _
            ScreenTip:="Blatt (" & .Value & ")", _
            TextToDisplay:=.Value
    End With
Next i

myRange.Select

MsgBox ("Es befinden sich ") & ThisWorkbook.Worksheets.Count & _
    (" Tabellenblätter in dieser Arbeitsmappe."), vbOKOnly, ThisWorkbook.Name
End Sub

Aktif sayfada a1 0 ise b1 e olur b1 e ise resmi gösterir

Option Explicit
Private Sub Worksheet_Calculate()
   If Range("B1").Value = "E" Then
      ActiveSheet.Pictures(1).Visible = True
   Else
      ActiveSheet.Pictures(1).Visible = False
   End If
End Sub
'Thisworkbook a
Option Explicit

Aktif sayfada a1 den itibaren alt alta 3 hücreyi kalın yapar

Option Explicit
Sub Top3LinesAllSheets()
   Dim wkSheet As Worksheet
   For Each wkSheet In Application.Worksheets
        With wkSheet.PageSetup
          .PrintTitleRows = "$1:$3"
       End With
Sheets(wkSheet.Name).Rows("1:3").Font.Bold = True

Aktif sayfada aynı verilerin kontrolü

Veriler B,C,D,E sütununda
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' If Target.Column <> 6 Then Exit Sub ' burası aktif olursa yalnızca kontrolü f sütununa geçince yapar
For x = 2 To [b65536].End(3).Row - 1
For y = x + 1 To [b65536].End(3).Row
alan1 = Cells(x, 2) & Cells(x, 3) & Cells(x, 4) & Cells(x, 5)
alan2 = Cells(y, 2) & Cells(y, 3) & Cells(y, 4) & Cells(y, 5)
If alan1 = alan2 Then
If MsgBox(y & ".satırdaki veri " & x & ".nci satırda girilmiş," & y & ".satırı silmek istiyor musunuz?", vbYesNo, "Uyarı") = vbYes Then Range(Cells(y, 2), Cells(y, 5)).Delete
End If
Next
Next
End Sub

Aktif sayfada belli hücrelere girilen sayıların başına çift sıfır ekler


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim mahmut As Range, bayram As Range
    On Error GoTo pir:
    Set mahmut = Range("B3:C20,D1:D7")
    Application.EnableEvents = False
    For Each bayram In Range(Target.Address)
        If Not Intersect(bayram, mahmut) Is Nothing Then
            If bayram <> "" Then bayram = "'00" & bayram
        End If
    Next bayram
    Set mahmut = Nothing
pir:
    Application.EnableEvents = True
End Sub

Aktif sayfada comboboxta sayfa isimleri tıklayınca sayfaya gitme

Private Sub ComboBox1_Change()
ActiveSheet.Cells(1, 1).Select
If Not ComboBox1.Value = "" Then Worksheets(ComboBox1.Value).Select
Sheets(1).ComboBox1.Value = ""
End Sub

Aktif sayfada çıktı aldıktan sonra mesaj alma

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    If ActiveSheet.Name = "Tabelle1" Then
    Application.OnTime Time + TimeSerial(0, 0, 1), "AfterPrint"
    End If
End Sub

‘Modüle
Public Sub AfterPrint()
    MsgBox ("Ich werde erst angezeigt, nachdem der Druck ''angestossen'' wurde !!!")
    ' hier auszuführenden Code ergänzen
End Sub

Aktif sayfada rakama göre renk

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  Select Case Target.Value
    Case 1
      Target.Interior.ColorIndex = 2
    Case 2
      Target.Interior.ColorIndex = 3
    Case 3
      Target.Interior.ColorIndex = 4
    Case 4
      Target.Interior.ColorIndex = 5
    Case 5
      Target.Interior.ColorIndex = 6
    Case 6
      Target.Interior.ColorIndex = 7
    Case Else
      Target.Interior.ColorIndex = xlColorIndexNone
  End Select
End Sub