- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,878
- Excel Vers. ve Dili
- 2003 excell türkçe
ve
2007 excell türkçe
Bu kodda iki makro var
sadece aktar3 tıklayın kod derece ve kademeleri kendisi ilerletiyor.
daha sonra siz kendi makrolarınızı yani
aktar1 ve aktar2 tıklıyacaksınız.
sadece aktar3 tıklayın kod derece ve kademeleri kendisi ilerletiyor.
Kod:
Sub aktar3()
Dim s1, s2
Set s1 = Sheets("TÜM LİSTE")
ay = s1.Cells(1, "G").Value
Tarih = Val(Format("01." & Format(ay, "00") & "." & Format(Format(Now, "yyyy"), "0000"), "mm"))
s1.Range("A3:O500").Interior.ColorIndex = xlNone
s1.Range("A3:O500").Font.ColorIndex = 0
ReDim sut(15)
sut(1) = 4
sut(2) = 6
sut(3) = 8
sut(4) = 9
sut(5) = 9
sut(6) = 9
sut(7) = 9
sut(8) = 9
sut(9) = 9
sut(10) = 9
sut(11) = 9
sut(12) = 9
sut(13) = 9
sut(14) = 9
sut(15) = 9
turu = 7
derece_sutunu = 13
kademe_sutunu = 14
tarih_sutunu = 15
ay = s1.Cells(1, turu).Value
ARANACAK_DEGER = Format(s1.Cells(1, turu).Value, "mmmm")
For i = 3 To s1.Cells(Rows.Count, "F").End(3).Row
If Tarih = Val(Format(CDate(s1.Cells(i, tarih_sutunu).Value), "mm")) Then
s1.Cells(i, derece_sutunu).Interior.ColorIndex = 6
s1.Cells(i, kademe_sutunu).Interior.ColorIndex = 6
s1.Cells(i, tarih_sutunu).Interior.ColorIndex = 6
yer = s1.Cells(i, kademe_sutunu).Value
yer1 = s1.Cells(i, derece_sutunu).Value
son = 0
For j = 1 To 15
If yer1 = j Then
son = sut(j)
Exit For
End If
Next j
If yer1 & yer = 13 Then
s1.Cells(i, derece_sutunu).Value = 1
s1.Cells(i, kademe_sutunu).Value = 4
Else
kontrol2 = 0
If s1.Cells(i, turu).Value <> "Ortaokul" Or s1.Cells(i, turu).Value <> "Lise" Then kontrol2 = 1
If s1.Cells(i, derece_sutunu).Value <= 2 Then
kontrol2 = 0
Else
End If
If kontrol2 = 1 Then
If yer = 1 Then
s1.Cells(i, kademe_sutunu).Value = 2
ElseIf yer = 2 Then
s1.Cells(i, kademe_sutunu).Value = 3
ElseIf yer = 3 Then
s1.Cells(i, kademe_sutunu).Value = 1
If s1.Cells(i, derece_sutunu).Value > 1 Then
s1.Cells(i, derece_sutunu).Value = s1.Cells(i, derece_sutunu).Value - 1
End If
End If
Else
If s1.Cells(i, kademe_sutunu).Value < son Then
For n = 1 To son
If s1.Cells(i, kademe_sutunu).Value = n Then
s1.Cells(i, kademe_sutunu).Value = n + 1
Exit For
End If
Next n
Else
If s1.Cells(i, derece_sutunu).Value > 1 Then
s1.Cells(i, derece_sutunu).Value = s1.Cells(i, derece_sutunu).Value - 1
ekle = 0
If s1.Cells(i, derece_sutunu).Value <= 2 Then
ekle = 1
End If
s1.Cells(i, kademe_sutunu).Value = son - 1 - ekle
End If
End If
End If
End If
End If
Next
End Subdaha sonra siz kendi makrolarınızı yani
aktar1 ve aktar2 tıklıyacaksınız.
