Excel'le Adım Adım Program Yazma

KOLON SAYISINI GİZLEME

1 Den 26 ya kadar olan kolon sayısı kadar gizleme

Sub LeereSpalteAus()
Dim i%
    For i = 1 To 26
        If IsEmpty(Cells(Rows.Count, i).End(xlUp)) Then
            Columns(i).Hidden = True
        End If
    Next i
End Sub

SATIR EKLEME

1. Satirla 2. Satir arasina 7 tane satir ekledİ

Sub SATIREKLE()
For i = 2 To 8
If Cells(i, 1) <> Cells(i + 1, 1) Then
Rows(i + 1).EntireRow.Insert
End If
Next i
End Sub

sizin yaptığınızdan esinlenerek şöyle bir şey yaptım. O da sadece 1. satırla 2. satır arasına 7 tane satır ekledi. Yani döngüde ilk if'in sağlandığı yere.

SAYFA EKLEME

"hesap" adlı sayfayı kopyalayarak 10 adet çoğaltır

Sub Modul_Loeschen()
    Dim Ini As Integer
    For Ini = 2 To 10
        Sheets("hesap").Copy After:=Sheets(Worksheets.Count)
        ActiveSheet.Name = Ini & ".pir"
    Next Ini
    With Application.VBE.ActiveVBProje ct
      .vbComponents.Remove .vbComponents("Modul1")
    End With
End Sub

SATIR VE SÜTUN SEÇME

1.Satır 1.Sütunu seç

Sub sec()
Cells(1, 1).Select
End Sub

SAYFALARI SİLME

1.sayfa hariç diğerlerini uyarısız siler

Sub birincisayfaharicsil()
Application.DisplayAlerts = False
While Worksheets.Count > 1
Sheets(2).Delete
Wend
Application.DisplayAlerts = True
End Sub

SAYFALARI GİZLEME

1.Sayfa hariç tüm sayfalari gİzle

Sub xlVeryHidden_All_Sheets()
On Error Resume Next
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Visible = xlVeryHidden
Next
End Sub

SAYFAYI AÇMA

1.Sayfayı açma

Sub FirstSheet()
Sheets(1).Select
End Sub

SÜRELİ MESAJ

10 Sn süreli mesaj

ThisWorkbook a
Private Sub Workbook_Open()
Dim WshShell
Dim intText As Integer
Set WshShell = CreateObject("WScript.Shell")
    intText = WshShell.Popup("Diese ''MsgBox'' wird nach 10 sec geschlossen", _
           10, "''MsgBox'' für 10 sec (©)2003 KMB", vbSystemModal)
End Sub

GİZLEME GÖSTERME
10.Satırdan itibaren gizleme ve gösterme

Sub BenutzterBereich()
    Dim WsTabelle As Worksheet
    On Error Resume Next
    For Each WsTabelle In Worksheets
        With WsTabelle
            .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden = _
                Not .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden
            .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden = _
                Not .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden
        End With
    Next WsTabelle
End Sub

BUTON BAR EKLE KALDIR
Sub Auto_Open()
    Toolbars("100 Button Faces").Visible = True
    Toolbars("Custom Toolfaces").Visible = True
End Sub

Sub Auto_Close()
    Toolbars("100 Button Faces").Delete
    Toolbars("Custom Toolfaces").Delete
End Sub

2 Listboxlar arası veri taşıma

Private Sub UserForm_Initialize()
    ListBox1.RowSource = "A1:A" & Cells(65536, 1).End(xlUp).Row
    ListBox1.ListStyle = fmListStyleOption
    ListBox1.MultiSelect = fmMultiSelectMulti
End Sub
'
Private Sub CommandButton1_Click()
    ListBox2.Clear
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            ListBox2.AddItem ListBox1.List(i)
        End If
    Next
End Sub

2.sütunda çift tıkla eklenecek satırı belirle

Private Sub Worksheet_BeforeDoubleClick(ByVal _
       Target As Range, Cancel As Boolean)
   'D.McRitchie, 2004-09-21, nsert more rows up
   ' until 15, no deletions of rows
   If Target.Column <> 2 Then Exit Sub
   If Not IsNumeric(Target) Then Exit Sub
   Cancel = True
   Dim i As Long, curv As Long, tov As Long
   curv = Target.Value
   tov = InputBox("supply new total rows", _
      "Rows input", curv + 1)
   If tov < curv Then Exit Sub
   For i = curv + 1 To tov
      Cells(Target.Row + i - 1, 1).EntireRow.Insert
      Cells(Target.Row + i - 1, 3) = i
      Cells(Target.Row, 2) = i
   Next i
End Sub

3 Boyutlu hücreye kenarlık

Sub Makro1()
    With ActiveCell.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
End Sub

3 Kere şifre hakkı

Sub auto_open()
Static sayac As Integer
Do
If sayac = 3 Then
ThisWorkbook.Close False
Else
If InputBox("Şifreyi girin") = "1" Then
GoTo devam
Else
sayac = sayac + 1
End If
End If
Loop
devam:
End Sub

3 Sn içerisinde msg box alarm

Sub timerMsg()
Dim alertTime
MsgBox "The alarm will go off in 3 seconds!"
alertTime = Now + TimeValue("00:00:03")
Application.OnTime alertTime, "msg"
End Sub

Sub msg()
MsgBox "Three Seconds is up!"
End Sub