Excel'le Adım Adım Program Yazma

Aktif hücrenin adresini mesajla öğrenme

Sub Aktive_Zelle()
az = ActiveCell.Address
MsgBox az
End Sub

Aktif hücrenin altındaki boş olan satırları siler


Sub bossasil()
Dim N As Long
For N = Selection(1, 1).Row + Selection.Rows.Count - 1 _
To Selection(1, 1).Row Step -1
With Cells(N, 1)
If .Value = 0 And Not .HasFormula Then
.EntireRow.Delete
End If
End With
Next N
End Sub

Aktif hücrenin bulunduğu satır renklensin


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Cells.Interior.ColorIndex = 0  'Turn off previous use
   If Cells(1, 1) = "." Then Exit Sub
   Target.EntireRow.Interior.Col orIndex = 38
End Sub

Aktif hücrenin bulunduğu satırı seçer

Sub SelectEntireRow()
    Selection.EntireRow.Select
End Sub

Aktif hücrenin bulunduğu sütunu (kolonu) seçer

Sub SelectEntireColumn()
    Selection.EntireColumn.Select
End Sub

Aktif hücrenin cinsini bulma


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Application.IsText(ActiveCell) = True Then
        MsgBox "Bu hücrede YAZI vardır."
            Else
                If ActiveCell = "" Then
                    MsgBox "Bu hücre BOŞ tur."
                        Else
                            End If

    If ActiveCell.HasFormula Then
        MsgBox "Bu hücrede FORMÜL vardır"
            Else
                End If

    If IsDate(ActiveCell.Value) = True Then
        MsgBox "Bu hücrede TARİH vardır"
            Else
                End If
     If IsNumeric(ActiveCell.Value) = True Then
         MsgBox "Bu hücrede SAYI vardır"
             Else
                 End If
                     End If
End Sub

Aktif hücrenin numerik veya yazı olduğunu kontrol etme


Sub numeric_control()
If Not Application.IsNumber(ActiveCell) Then
MsgBox "Numerik değil"
Else
MsgBox "Numerik"
End If
End Sub

Sub text_control()
If Not Application.IsText(ActiveCell) Then
MsgBox "Yazı değil"
Else
MsgBox "Yazı"
End If
End Sub

Aktif hücreyi sayfa başına çıkarır.


Sayfanın kod bölümüne

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Goto Reference:=ActiveCell, Scroll:=True
End Sub

Aktif hücrenin üstüne 4 satır ekler

Sub dortsatirekle()
ActiveCell.Rows("1:4").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(3, 0).Range("A1").Select
End Sub

Aktif hücrenin yazdırılması


Sub PrintSelectedCells()
Dim aCount As Integer, cCount As Integer, rCount As Integer
Dim i As Integer, j As Long, aRange As String
Dim rHeight() As Single, cWidth() As Single
Dim AWB As Workbook, NWB As Workbook
    If UCase(TypeName(ActiveSheet)) <> "WORKSHEET" Then Exit Sub
    aCount = Selection.Areas.Count
    If aCount = 0 Then Exit Sub ' no cells selected
    cCount = Selection.Areas(1).Cells.Count
    If aCount > 1 Then ' multiple areas selected
        Application.ScreenUpdating = False
        Application.StatusBar = "Printing " & aCount & " selected areas..."
        Set AWB = ActiveWorkbook
        rCount = ActiveSheet.Cells.SpecialCell s(xlLastCell).Row
        cCount = ActiveSheet.Cells.SpecialCell s(xlLastCell).Column
        ReDim rHeight(rCount)
        ReDim cWidth(cCount)
        For i = 1 To rCount
            rHeight(i) = Rows(i).RowHeight
        Next i
        For i = 1 To cCount
            cWidth(i) = Columns(i).ColumnWidth
        Next i
        Set NWB = Workbooks.Add ' create a new workbook
        For i = 1 To rCount ' set row heights
            Rows(i).RowHeight = rHeight(i)
        Next i
        For i = 1 To cCount ' set column widths
            Columns(i).ColumnWidth = cWidth(i)
        Next i
        For i = 1 To aCount
            AWB.Activate
            aRange = Selection.Areas(i).Address
            Range(aRange).Copy ' copying the range
            NWB.Activate
            With Range(aRange) ' pastes values and formats
                .PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
                .PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
            End With
            Application.CutCopyMode = False
        Next i
        NWB.PrintOut
        NWB.Close False ' close the temporary workbook without saving
        Application.StatusBar = False
        AWB.Activate
        Set AWB = Nothing
        Set NWB = Nothing
    Else
        If cCount < 10 Then ' less than 10 cells selected
            If MsgBox("Are you sure you want to print " & _
                cCount & " selected cells ?", _
                vbQuestion + vbYesNo, "Print celected cells") = vbNo Then Exit Sub
        End If
        Selection.PrintOut
    End If
End Sub

Aktif hücreye açıklama ekleme ve o açıklamanın yazı tipi ve puntosunu ayarlama


Sub commenter()
    Dim Cmt As Comment
    Set Cmt = ActiveCell.AddComment
    Cmt.Text "Mahmut BAYRAM"
    With Cmt.Shape.TextFrame.Character s.Font
        .Name = "Arial"
        .Size = 14
    End With
End Sub

Aktif hücreye bugünün tarihini ekler.

Sub FirmDate()
     Selection.Value = Date
End Sub
Font listele

Sub SchriftLesen()
  Dim C As CommandBarControl
  Dim i As Integer
  Set C = CommandBars.FindControl(ID:=1728)
  For i = 1 To C.ListCount
    With Cells(i, 1)
      .Value = C.List(i)
      .Font.Name = C.List(i)
    End With
  Next i
End Sub

Aktif hücreye Çalışma kitabının ve aktif sayfanın adını yazdırır

Sub KitapveSayfaadi()
ActiveCell.Value = ExecuteExcel4Macro("get.document(1)")
End Sub

Aktif hücreye çift tıkla 1 artırsın


Private Sub Worksheet_BeforeDoubleClick(ByVal Target _
       As Range, Cancel As Boolean)
  Cancel = True   'Get out of edit mode
  If Target.Row = 1 Then Exit Sub
  If Target.Column <> 2 Then Exit Sub  'Require Col B
  On Error Resume Next
  Application.EnableEvents = False
  Target.Value = Target.Value + 1
  Application.EnableEvents = True
  If Err.Number <> 0 Then
     MsgBox "Unable to add 1 to value in cell " _
       & Target.Address(0, 0)
  End If
End Sub

Aktif hücreye çift tıkla alttoplam eklesin


Private Sub Worksheet_BeforeDoubleClick(ByVal _
     Target As Range, Cancel As Boolean)
         'David McRitchie,  misc, 2001-07-02
   '-- Find top cell in continguous range
   Cancel = True   'Get out of edit mode
   Range(Target.Offset(-1, 0).End(xlUp), Target).Select
   '-- leave selection of cells showing for visual verification.
   Target.Formula = "=SUBTOTAL(9," _
     & Selection(1).Address(0, 0) & ":" _
     & Selection(Selection.Count - 1).Address(0, 0) & ")"
   'make the double-clicked cell the active cell for the range
   Target.Activate
End Sub