#1
nöbet hesap listesi.rar
(Dosya Boyutu: 3,51 KB | İndirme Sayısı: 10)
Private Sub btnAktar_Click()
Dim i As Byte, k As Byte, topla As Integer
Const baslangic As Byte = 3
Const bitis As Byte = 66
Const bitisYarisi As Byte = 33
Const A As String = "A"
Const B As String = "B"
Const D As String = "D"
Const E As String = "E"
Range("I3:J33").ClearContents
'Haftasonu bulmak icin
For i = baslangic To bitis
For k = baslangic To bitis
If k > bitisYarisi Then GoTo var
If Cells(i, B).Value <> "" And Cells(i, B).Value = Cells(k, B).Value Then
If Weekday(Cells(k, A), 2) >= 6 Then topla = topla + 1
End If
var:
If Cells(i, E).Value <> "" And Cells(i, E).Value = Cells(k, E).Value Then
If Weekday(Cells(k, D), 2) >= 6 Then topla = topla + 1
End If
Next
Cells(i, "j").Value = IIf(topla = 0, "", topla)
topla = Empty
Next
topla = Empty
'Haftaici bulmak icin
For i = baslangic To bitis
For k = baslangic To bitis
If k > bitisYarisi Then GoTo var2
If Cells(i, B).Value <> "" And Cells(i, B).Value = Cells(k, B).Value Then
If Weekday(Cells(k, A), 2) < 6 Then topla = topla + 1
End If
var2:
If Cells(i, E).Value <> "" And Cells(i, E).Value = Cells(k, E).Value Then
If Weekday(Cells(k, D), 2) < 6 Then topla = topla + 1
End If
Next
Cells(i, "i").Value = IIf(topla = 0, "", topla)
topla = Empty
Next
End Sub
Private Sub btnAktar_Click()
Dim i As Byte, topla As Integer
Dim son As Byte, adres As String
Dim bul As Range
Range("I3:J" & Rows.Count).ClearContents
'Hafta ici bulmak icin
son = Cells(Rows.Count, "H").End(3).Row
If son < 3 Then GoTo son
For i = 3 To son
If Cells(i, "H").Value <> "" Then
Set bul = Range("B:E").Find(Cells(i, "H").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) < 6 Then topla = topla + 1
Set bul = Range("B:E").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
Cells(i, "i").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
End If
Next
'Hafta sonu bulmak icin
For i = 3 To son
If Cells(i, "H").Value <> "" Then
Set bul = Range("B:E").Find(Cells(i, "H").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) >= 6 Then topla = topla + 1
Set bul = Range("B:E").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
Cells(i, "j").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
End If
Next
son:
On Error Resume Next
Set bul = Nothing
End SubPrivate Sub btnAktar_Click()
Dim i As Byte, topla As Integer
Dim son As Byte, adres As String
Dim bul As Range, alan As Range
Set alan = Union(Range("B:B"), Range("E:E"))
Range("I3:J" & Rows.Count).ClearContents
'Hafta ici bulmak icin
son = Cells(Rows.Count, "H").End(3).Row
If son < 3 Then GoTo son
For i = 3 To son
If Cells(i, "H").Value <> "" Then
Set bul = alan.Find(Cells(i, "H").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) < 6 Then topla = topla + 1
Set bul = alan.FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
Cells(i, "i").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
End If
Next
'Hafta sonu bulmak icin
For i = 3 To son
If Cells(i, "H").Value <> "" Then
Set bul = alan.Find(Cells(i, "H").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) >= 6 Then topla = topla + 1
Set bul = alan.FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
Cells(i, "j").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
End If
Next
son:
On Error Resume Next
Set bul = Nothing
Set alan = Nothing
End Sub