RENGE GÖRE TOPLAMA İŞLEMİ YAPMAK
Function Renklitopla(InRange As Range, WhatColorIndex As Integer, Optional OfText As Boolean =
False) As Double
Dim Rng As Range
Dim OK As Boolean
Application.Volatile True
For Each Rng In InRange.Cells
If OfText = True Then
OK = (Rng.Font.ColorIndex = WhatColorIndex)
Else
OK = (Rng.Interior.ColorIndex = WhatColorIndex)
End If
If OK And IsNumeric(Rng.Value) Then
Renklitopla = Renklitopla + Rng.Value
End If
Next Rng
End Function
Public Function ozellik(Ornek_Hucre)
FontRengi = Ornek_Hucre.Font.ColorIndex
DolguRengi = Ornek_Hucre.Interior.ColorIndex
ozellik = "fontrengi= " & FontRengi & " / dolgurengi= " & DolguRengi
End Function
Function brdrenktopla(Adres As Range, Dolgu_rengi, Font_rengi, islem As Integer)
Dim c As Range
On Error Resume Next
toplam = 0
If islem = 1 Then
For Each c In Adres
If c.Interior.ColorIndex = Dolgu_rengi And c.Font.ColorIndex = Font_rengi And c <> "" Then
toplam = toplam + c.Value
Next
End If
brdrenktopla = toplam
End Function
Function deneme(hucrerenk As Range, alan As Range)
Dim toplam As Long
For Each x In alan
If x.Interior.ColorIndex = hucrerenk.Interior.ColorIndex Then
toplam = toplam + x.Value
End If
Next
deneme = toplam
End Function
Sub denemex()
MsgBox Range("c2").Interior.ColorIndex
MsgBox Range("G9").Interior.ColorIndex
End Sub
BÜYÜK/KÜÇÜK HARF DEĞİŞTİRME
Sub buyuk()
bak = Selection.Count
For i = 1 To bak
Selection(i).Replace What:="i", Replacement:="İ", MatchCase:=True
Selection(i).Replace What:="ı", Replacement:="I", MatchCase:=True
Selection(i) = UCase(Selection(i))
Next i
End Sub
Sub kucuk()
bak = Selection.Count
For i = 1 To bak
Selection(i).Replace What:="İ", Replacement:="i", MatchCase:=True
Selection(i).Replace What:="I", Replacement:="ı", MatchCase:=True
Selection(i) = Lcase(Selection(i))
Next i
End Sub
Sub BasharfBuyuk()
bak = Selection.Count
For i = 1 To bak
Selection(i) = Application.Proper(Selection(i))
Next i
End Sub
RAKAMSAL İFADELERİ YAZIYLA GÖSTEREN FONKSİYON
Function yaziyla(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
b = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
c = Array("", "", "bin", "milyon", "milyar", "trilyon")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e=e+1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "yüz", "biryüz", "yüz")
s(2) = b(deg(2))
s(3) = a(deg(3)) & c(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "birbin" Then son = Replace(son, "birbin", "bin")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then TL = son & " TL"
If g = 2 And deger(2) <> 0 Then KR = " " & son & " KR"
son = ""
e=0
Next
yaziyla = TL & KR
End Function
ÇALIŞMA SAYFALARINI SIRALAMA
Sub SayfaSırala()
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean
SortDescending = False
If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If
For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
End Sub
RAPOR OLUŞTURAN MAKRO
Sub DevamVeBitenRaporu()
' DevamVeBitenRaporu Macro
' Keyboard Shortcut: Ctrl+t
Sheets("DevamEdenler").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("G10").Select
Sheets("Bitenler").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("E10").Select
Sheets("Makro").Select
Range("E1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$H$40").AutoFilter Field:=8, Criteria1:="Bitti"
Range("A1:H40").Select
Range("E1").Activate
Selection.Copy
Sheets("DevamEdenler").Select
Range("A1").Select
Sheets("Bitenler").Select
Range("A1").Select
Sheets("Bitenler").Select
ActiveSheet.Paste
Columns("G:G").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Sheets("Makro").Select
ActiveSheet.Range("$A$1:$H$40").AutoFilter Field:=8, Criteria1:="Bitti"
ActiveSheet.Range("$A$1:$H$40").AutoFilter Field:=8, Criteria1:="Devam"
Application.CutCopyMode = False
Selection.Copy
Sheets("DevamEdenler").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Sheets("Makro").Select
Range("E1").Select
Application.CutCopyMode = False
Selection.AutoFilter
End Sub
KOŞULLU VERİ ÇEKME
Sub FazlaMesai()
Sheets("Fazla Mesai").Select
Cells.Select
Range("A4").Activate
Selection.Delete Shift:=xlUp
Sheets("Ocak Ayı Genel Bordro").Select
Range("A20").Select
Selection.AutoFilter
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveSheet.Range("$A$20:$P$85").AutoFilter Field:=4, Criteria1:=">0", _
Operator:=xlAnd
Selection.CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Fazla Mesai").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Columns("A:A").Select
Range("A4").Activate
Range(Selection, Selection.End(xlToRight)).Select
Columns("A:P").EntireColumn.AutoFit
Selection.End(xlToLeft).Select
Sheets("Ocak Ayı Genel Bordro").Select
Application.CutCopyMode = False
Selection.AutoFilter
Range("A20").Select
End Sub
Ad ve Soyadları Sütunlara Bölmek
Sub Ad_Soyad_Ayir()
Columns("b:c").ClearContents
For q = 2 To [a65536].End(3).Row
deg = Split(Trim(Cells(q, 1)), " ")
For x = LBound(deg) To UBound(deg)
If Replace(Right(deg(x), 1), "ı", "i") = Right(UCase(deg(x)), 1) Then Soyad = Soyad & deg(x) & " "
Else
Ad = Ad & deg(x) & " "
End If
Next
Cells(q, 2) = Trim(Ad)
Cells(q, 3) = Trim(Soyad)
Ad = "": Soyad = ""
Next
MsgBox "Ayırma işlemi tamamlandı.", vbInformation, "Kodlayan: l e u m r u k"
End Sub
