Excel'le Adım Adım Program Yazma

A1 hücresinde saat

Dim stopit As Boolean 'on top of module!

Sub startclock() 'assign start button
stopit = False
clock
End Sub

Sub clock()
If stopit = True Then Exit Sub
ActiveWorkbook.Worksheets(1).Cells(1, 1).Value = _
Format(Now, "hh:mm:ss")
Application.OnTime (Now + TimeSerial(0, 0, 1)), "clock"
End Sub

Sub stopclock() 'assign stop button
stopit = True
End Sub

A1 hücresindeki isimle sayfayı istenilen yere kaydetme

Sub Enreg_Fichier()
    Dim NomFichier As String
    NomFichier = Range("A1")
    ActiveWorkbook.SaveAs "c:\excel\" & NomFichier
End Sub

A1 hücresindeki isimle yeni sayfa

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$A$1" And Target.Value = 1 Then
Dim sayfa As Worksheet
    Dim önek As String
    Dim sonek As Integer
   
    Set Sayfam = Worksheets.Add
    önek = "Sayfam"
    SonEkim = 1
   
    On Error Resume Next
    Sayfam.Name = önek & sonek
    If Err.Number <> 0 Then
        önek = sonek + 1
        Sayfam.Name = önek & sonek
    End If
    End If
End Sub

A1 hücresine hapsetmek

Application.Sheets("Sayfa Adı").ScrollArea = "A1"

A1 hücresine rakam yazmak mecburi yoksa diğer hücrelere geçiş yasak


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not IsNumeric(Range("A1")) Or Range("A1") = "" Then
        Range("A1").ClearContents
        Range("A1").Select
        MsgBox "Lütfen sayı giriniz!"
        End If
End Sub

A1 i 1 artırma


Sub Count()
    mycount = Range("a1") + 1
      Range("a1") = mycount
 End Sub

Sub Workbook_Open()
    With Worksheets(1).Range("A1")
        .Value = .Value + 1
    End With
End Sub

A1 ile sayfa ekleme ekleyerek

Sub FeuilViaLst()
Dim Mycell As Range, Mysheet As Worksheet, MyName$
For Each Mycell In Selection 'liste de noms
MyName = Mycell.Value
If MyName <> "" Then
On Error Resume Next
Set Mysheet = Sheets(MyName)
On Error GoTo 0
If Mysheet Is Nothing Then Sheets.Add.Name = MyName
End If
Next Mycell
End Sub

A1 itibaren sayfa isimlerini yaz

Sub ListeFeuilles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ArrFeuil = Sheets("Sayfa1")
ArrFeuil.Cells(1, 1).Value = "Tableau des feuilles"
For i = 2 To ActiveWorkbook.Sheets.Count
ArrFeuil.Cells(i, 1).Value = Sheets(i).Name
Next i
Application.DisplayAlerts = True
Alerte = True
Application.ScreenUpdating = True
End Sub

A1 sütununda çift kayıt girmek yasak (hücreyeelle girersen siler)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).ClearContents
Next
End Sub

A1 ve b1 hücresindeki verileri birleştirme

Sub birlestir()
For a=1 To cells(65536,1).end(xlup).row
cells(a,3)=cells(a,1) & " " & cells(a,2)
Next
End Sub

A1, a3 ten küçükse mesaj verir.

Private Sub Worksheet_Calculate()
If Range("A1").Value < Range("A3").Value Then
    Call Macro1
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Address = "$A$1" Or Target.Address = "$A$3" Then
        If Range("A1").Value < Range("A3").Value Then
        Call Macro2
Else
End If
End If
End Sub

Sub Macro1()
MsgBox " bu 1.makrodur"
End Sub

Sub Macro2()
MsgBox " bu 2.makrodur"
End Sub

A1,b1,c1,d1 e yazı yaz kolonları seç ve sil (bekletmeli silme)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    For Each TmpRng In Target
        TmpVal = TmpRng.Validation.Type
        If TmpVal > 0 Then
            If Application.CutCopyMode = 1 Then
                MsgBox "You cannot paste into validated cells."
                Application.CutCopyMode = False
                Exit Sub
            End If
        End If
    Next
End Sub

A1:a10 , c1:c10 u karşılaştırır girilen rakamlar farklı ise uyarı verir.

Private Sub Worksheet_Change(ByVal Target As Range)
If [a10].Value <> [c10].Value Then MsgBox ("Girdiğiniz rakamlar farklı")
End Sub

A1:a10 arasındaki hücreleri rastgele seçer:

Sub rast()
Dim rastgele As Integer
ilk:
rastgele = Int(Rnd() * 11)
If rastgele <= 0 Or rastgele > 11 Then GoTo ilk
Cells(rastgele, 1).Select
End Sub

A1:A10 hücreleri arasında 10 dan büyükleri kalın yapar

Sub buyukler_kalin()
Cells(Rows.Count, "A").End(xlUp).Select
For Each rgRow In Range("a1:a10").Rows
   If rgRow.Cells(1).Value > 10 Then
      rgRow.Font.Bold = True
   Else
      rgRow.Font.Bold = False
   End If
Next rgRow
End Sub