Aslında koda tıklayınca isimleri otomatikte getirilebilir sıralı şekilde.
Private Sub btnAktar_Click()
Dim syf As Worksheet
Dim i As Byte, topla As Integer
Dim son As Byte, adres As String
Dim bul As Range
'Hafta ici bulmak icin
With ActiveSheet
Application.ScreenUpdating = False
.Range("B3:C" & Rows.Count).ClearContents
son = .Cells(Rows.Count, "A").End(3).Row
If son < 3 Then GoTo son
For i = 3 To son
For Each syf In Worksheets
If syf.Name <> .Name Then
If .Cells(i, "A").Value <> "" Then
Set bul = syf.Range("B:B").Find(.Cells(i, "A").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 = syf.Range("B:B").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
End If
End If
Next
.Cells(i, "B").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
Next
'Hafta sonu bulmak icin
For i = 3 To son
For Each syf In Worksheets
If syf.Name <> .Name Then
If .Cells(i, "A").Value <> "" Then
Set bul = syf.Range("B:B").Find(.Cells(i, "A").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 = syf.Range("B:B").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
End If
End If
Next
.Cells(i, "C").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
Next
MsgBox "islem tamamlandi...", vbInformation, "Bilgi"
son:
Application.ScreenUpdating = True
End With
On Error Resume Next
Set bul = Nothing
Set syf = Nothing
End Sub
