Excel'le Adım Adım Program Yazma

Excel dosyasi İÇİnde bİr kelİme aratma

Sub FileList()
Dim FileNamesList As Variant, i As Integer
FileNamesList = CreateFileList("*.xls", True)
Range("A:B").ClearContents
For i = 1 To UBound(FileNamesList)
Cells(i + 1, 1) = FileNamesList(i)
Cells(i + 1, 2) = FileSize(Dir(FileNamesList(i)))
Next
Columns("A:B").AutoFit
End Sub
Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
With Application.FileSearch
.NewSearch
.LookIn = "D:\Belgelerim\"
.Filename = FileFilter
.SearchSubFolders = IncludeSubFolder
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next
End With
CreateFileList = FileList
Erase FileList
End Function

Function FileSize(filespec)
Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("D:\Belgelerim\")
Set fc = f.Files
For Each f1 In fc
If f1.Name = filespec Then FileSize = f1.Size / 1024 & " Kb"
Next
End Function


Dosyalar Geldikten Sonra şu makro ile Dosyaların adlarını ayırarak İstediğin dosyayı fonksiyonlarla Bulabilirsin..Tabi bu yöntem tam istediğiniz değil ama yinede örnek olarak bulunsun.Kod:
Sub ayır()
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
    ActiveWindow.ScrollColumn = 2
End Sub

4 işlem programı

Private Sub Command1_Click()
Dim sayı1, sayı2, sonuç As Double
sayı1 = Val(Text1.Text)
sayı2 = Val(Text2.Text)
If Option1 = True Then sonuç = sayı1 + sayı2
If Option2 = True Then sonuç = sayı1 - sayı2
If Option3 = True Then sonuç = sayı1 * sayı2
If Option4 = True Then sonuç = sayı1 / sayı2
Text3.Text = Str(sonuç)
End Sub

OTOMATİK MAKRO

4. Satırda işlem yapılırsa macro otomatik çalışsın

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Row = 4 Then MsgBox "Aşkından Selamlar"
End Sub

OTOMATİK MAKRO

4. sütünda işlem yapılırsa macro otomatik çalışsın



Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 4 Then MsgBox "Aşkın'dan Selamlar"
End Sub

ZAMANLI KAYIT

5 Dk da bir kitabı kaydetme

Sub auto_open()
Application.OnTime Now + TimeValue("00:05:00"), "Kayıt"
End Sub

Sub Kayıt()
ActiveWorkbook.Save
MsgBox "Kitap Kaydedildi"
Call auto_open
End Sub

5. Sütünundaki hücreye girilen veriye karşılık farklı farklı makroların çalışması

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Column <> 6 Then Exit Sub
   Select Case Target.Value
      Case "a"
         A_Makrosu
      Case "b"
         B_Makrosu
      Case "c"
         C_Makrosu
   End Select
End Sub

9 Farkli deĞer İÇİn koŞullu bİÇİmlendİrme

Aşağıdaki kodu sayfanın kod sayfasına kopyalayın. A1 hücresine yazdığınız sayı renk indexi olarak kabul edilmiştir.

    visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$A$1" Or IsNumeric(Target) = False Then Exit Sub
    Target.Interior.ColorIndex = Target
    End Sub

A hücresindeki değere göre sayfaya kaydetme

Sub aktar()
Set verisayfasi = Sheets(1)
Select Case Range("a1").Value
Case "A"
Set sayfam = Sheets(1)
Case "B"
Set sayfam = Sheets(2)
Case "C"
Set sayfam = Sheets(3)
Case "D"
Set sayfam = Sheets(4)
End Select
ensonhucre = sayfam.Range("A65000").End(xlUp).Row  'son hucreye A sutunundan baktım
For i = 1 To 5
sayfam.Cells(ensonhucre, i) = verisayfasi.Cells(2, i)
Next
End Sub

A ile b'yi karşılaştır, aynı olanları c'ye, farklı olanları d'ye yaz

Sub bul()
For a = 2 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Columns(1), Cells(a, 2).Value) = 0 Then
e = WorksheetFunction.CountA([d2:d65536]) + 1
Cells(e + 1, 4) = Cells(a, 2).Value
End If
If WorksheetFunction.CountIf(Columns(2

A Sutununu otomatik kopyala

    Set LookupRange = Intersect(LookupSheet.Columns("A"), LookupSheet.UsedRange)
    Set DestRange = DestSheet.Range("A65536").End(xlUp).Offset(1, 0)
    Found = False
    If n <> "" Then
        For Each cell In LookupRange
                If cell.Value = n Then
                    delrange = cell.Address
                    cell.EntireRow.Cut DestRange
                    Found = True
                    Exit For
                End If
        Next cell
    End If   
    If Not Found Then
        msg = "The code does not exist on " & LookupSheet.Name & "."
        MsgBox msg, vbOKOnly, "AutoCopy"
    Else
        LookupSheet.Range(delrange).EntireRow.Delete
        DestSheet.Select
        Range("A65536").End(xlUp).EntireRow.Select
    End If   
End Sub

A sutununa abc yazınca makro otomatik çalışsın

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If Target = "abc" Then Call Test
End Sub
Sub Test()
    MsgBox "Tebrikler..!", vbInformation
End Sub

A sütununda aralarda boş satırları siler ve yukarı çeker

Option Explicit
Sub Leerzeilenlöschen()
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

A sütununda aynı değerde olanları yazdırma alanı olarak ayırır

Sub AutoBreak()
    Set Urange = ActiveSheet.UsedRange
    Set ColA = Range("A:A")
    Set Arange = Intersect(ColA, Urange)
    Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1)
   
    Cells.PageBreak = xlNone
   
    For Each cell In Brange
        If cell.Value <> cell.Offset(1, 0).Value Then
            cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual
        End If
    Next
End Sub

A sütununda aynı olanlardan 1 tane bırakır diğerlerini siler ve alfabetik sıraya dizer

Sub Doppelte_löschen()
    Range("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
        xlTopToBottom
    Range("A1").Select
    nr = ActiveCell
    zellende = Range("A" & Rows.Count).End(xlUp).Row
    Do
        ActiveCell.Offset(1, 0).Range("A1").Select
        If ActiveCell = nr Then
            Selection.EntireRow.Delete
            ActiveCell.Offset(-1, 0).Range("A1").Select
        End If
        nr = ActiveCell
    Loop Until ActiveCell = Range("A" & zellende + 1)
End Sub

A sütununda aynı olanları sayfa alanı olarak ayırır

Sub AutoBreak()
    Set Urange = ActiveSheet.UsedRange
    Set ColA = Range("A:A")
    Set Arange = Intersect(ColA, Urange)
    Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1)
    Cells.PageBreak = xlNone
    For Each cell In Brange
        If cell.Value <> cell.Offset(1, 0).Value Then
            cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual
        End If
    Next
End Sub