Ayrıca Toplam Liste sayfasına diğer sayfalardan geçincede kod çalışıp veriler gelir.
Tabii berduş hocamızın kodu daha kısa.
Private Sub btnAktar_Click()
Dim syf As Worksheet, son1 As Byte, x As Byte
Dim i As Byte, topla As Integer, topla1 As Integer
Dim son As Byte, adres As String
Dim bul As Range, dict As Object
Dim arr()
Application.ScreenUpdating = False
With Sheets("Toplam Liste")
.Range("A3:C" & Rows.Count).ClearContents
Set dict = CreateObject("Scripting.Dictionary")
'Sayfalar tek tek dolasip A sütunundakiler benzersiz olarak dictionary icine alindi.
For Each syf In Worksheets
If syf.Name <> .Name Then
son1 = syf.Cells(Rows.Count, "A").End(3).Row
If son1 >= 3 Then
For x = 3 To son1
dict(CStr(syf.Range("B" & x).Value)) = dict(CStr(syf.Range("B" & x).Value))
Next
End If
End If
Next
'Haftaici ve hafta sonu icin kodlar
If dict.Count > 0 Then
.Range("A3").Resize(dict.Count, 1).Value = Application.Transpose(dict.keys)
son = .Cells(Rows.Count, "A").End(3).Row
If son < 3 Then GoTo son
ReDim arr(1 To son, 1 To 2)
.Range("A3:A" & son).Sort .Range("A3"), , , , , , , xlNo
For i = 3 To son
For Each syf In Worksheets
If syf.Name <> .Name 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
If Weekday(bul.Offset(0, -1), 2) > 5 Then topla1 = topla1 + 1
Set bul = syf.Range("B:B").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
End If
Next
arr(i - 2, 1) = IIf(topla > 0, topla, ""): arr(i - 2, 2) = IIf(topla1 > 0, topla1, "")
topla = Empty: topla1 = Empty: Set bul = Nothing
Next
.Range("B3").Resize(son, 2).Value = arr
MsgBox "islem tamamlandi...", vbInformation, "Bilgi"
End If
son:
Application.ScreenUpdating = True
End With
On Error Resume Next
kac = 0
Erase arr
Set bul = Nothing
Set syf = Nothing
Set dict = Nothing
End SubPrivate Sub Worksheet_Activate()
btnAktar_Click
End Sub
