Excel'le Adım Adım Program Yazma

A sütunundakileri benzersiz olacak şekilde ayıklar

Sub benzersiz()
    Columns("A:A").Select
    Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("C:C"), Unique:=True
    Range("C11").Select
End Sub

A  sütünunda a ları saydırır.

WorksheetFunction.CountA(Columns("A"))

A sütunundan g sütununa (g hariç) kadar olan hesaplamalar açık , diğer sütunlar butona basınca hesaplasın

Sub Auto_Open()
Application.Calculation = xlCalculationManual 'hesaplamayı el ile yapar
Application.OnKey "{F9}", "sec_hesapla" 'F9 tuşuna basınca sec_hesapla makrosunu çalıştırır
End Sub

Sub Auto_Close()
Application.Calculation = xlCalculationAutomatic 'çıkışta otomatik hesaplama yapar.
End Sub

Sub sec_hesapla()
Dim sec 'sec sabiti
sec = Range("A1:A9").Select 'sec sabitinin aralığı tanımlanır ve seçilir (A1:A9 arasında formüllerin olduğunu varsayıorum)
Selection.Calculate 'seçili olan aralık F9 tuşuna basılınca hesaplanır
End Sub

A sütununu hücrelerini çerçeve içerisine alır

Sub ZeilenFärben()
Dim Zeile As Range, ZeilenNr As Integer
For Each Zeile In Selection.Columns
ZeilenNr = ZeilenNr + 1
If ZeilenNr Mod 2 = 0 Then
Zeile.Interior.ColorIndex = 6
Else
Zeile.Interior.ColorIndex = xlAutomatic
End If
Zeile.Borders.Weight = xlThin
Next
End Sub

A sütünündaki sayıları sıralar (aradan biri silinice bile sıralar)

Dim say As Integer
 Dim i As Integer
 say = WorksheetFunction.CountA(Range("A2:A65000"))
    For i = 1 To say
        Cells(i + 1, 1) = i
    Next i

A sütünündaki sayıları sıralar (aradan biri silinice bile sıralar) 2

Sub sirala()
For x = 2 To [b65536].End(3).Row
Cells(x, 1).Value = x - 1
Next
End Sub

A ve c sütunundaki veriler aynıysa o satırı silsin

For C = [c65536].End(3).Row To 1 Step -1
If Cells(C, "c")=cells(C,"a") Then Rows(C).Delete
Next

A, b sütunlarını topla c'ye yaz


Sub abtoplaCyaz()
Dim i As Integer
On Error GoTo 10
For i = 1 To 50
If Cells(i, 1).Value <> Empty And Cells(i, 2).Value <> Empty And _
IsNumeric(Cells(i, 1).Value) And IsNumeric(Cells(i, 2).Value) Then
Cells(i, 3).FormulaR1C1 = WorksheetFunction.Sum(Val(Cells(i, 1).Value) + Val(Cells(i, 2).Value))
Else
10 MsgBox "Geçersiz değer bulundu, lütfen kontrol ediniz  ", vbExclamation, "H  A  T  A  !!! "
Exit Sub
End If
Next i
End Sub

a,b,c sütununda arar bulur


Dim bul As String
Private Sub CommandButton1_Click()
On Error GoTo 10
bul = InputBox("LÜTFEN ARANACAK ŞUBE KODUNU YADA İSMİNİ  GİRİNİZ!!!!!!")
bassat = Range("A4:C65536").Find(bul).Row
For a = bassat To 65536
sonsat = Range("A" & a, "C65536").Find(bul).Row
Next a
10 If sonsat = 0 Then
MsgBox ("ARADIĞINIZ VERİ BULUNAMADI")
Exit Sub
End If
Range("A" & bassat, "C" & sonsat).Select
End Sub

A,B,C,D sütunundaki verilerden H1 e yaz I1 de bulsun

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bul As Range, ilkadres, i
Application.ScreenUpdating = False
If Target.Address = "$H$1" Then
Sayfa1.[I1:I65536].ClearContents
Set Bul = Sayfa1.[A:A].Find(Target, LookAt:=xlWhole)
If Not Bul Is Nothing Then
ilkadres = Bul.Address
i = 1
Do
i = i + 1
Target(i - 1, 2) = Bul(1, 4)
Set Bul = Sayfa1.[A:A].FindNext(Bul)
Loop Until ilkadres = Bul.Address
End If
End If
End Sub

A sütunundaki dolu satırların altına boş satır ekler

Sub ZeileEinfuegen()

Dim Zeile As Integer

Zeile = 2

Application.ScreenUpdating = False

Do Until Range("a" & Zeile).Value = ""
Rows(Zeile & ":" & Zeile).Select
Selection.Insert Shift:=xlDown
Zeile = Zeile + 2
Loop

Range("A1").Select

Application.ScreenUpdating = True

End Sub

hÜcrelerİndekİ verİlerden lİstbox a sadece dolu hÜcrelerİ alir. (BoŞ hÜcreler gÖzÜkmez)

Private Sub UserForm_Initialize()
Dim myrange As Range

Dim myrange As Range

Set myrange = Range("A1:A200")

For Each c In myrange

If c.Value = ListBox1.Value Then
TextBox1.Value = ListBox1.Value & c.Value.Offset(1, 0).Value
End If
Next
End Sub

A1 0 ise 10 ve 20.Satırlar arasını gizle değilse göster

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If [a1].Value = 0 Then
    Rows("10:20").EntireRow.Hidden = True
    Else
    Rows("10:20").EntireRow.Hidden = False
    End If
End Sub

A1 0 ise a10:a20 arasını gizle değilse göster

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If [a1].Value = 0 Then
    Rows("10:20").EntireRow.Hidden = True
    Else
    Rows("10:20").EntireRow.Hidden = False
    End If
End Sub

A1 0 ise c10:c20 gizle 1 ise göster


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If [a1].Value = 0 Then
    Rows("10:20").EntireRow.Hidden = True
    Else
    Rows("10:20").EntireRow.Hidden = False
    End If
End Sub