(17/07/2020, 16:41)feraz yazdı: kodunuzu alttaki gibi düzenledim izninizle.

daha güzel oldu)

Son olarakönceden yazdığım koddaki gereksiz döngüleri silip kodu kısalttım.Ve Redim olarak ayarladım daha hızlı olması için

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 Sub

Private Sub Worksheet_Activate()

    btnAktar_Click

End Sub

sn feraz ve sn halil hocalarım,
ellerinize, emeğinize ve yüreğinize sağlık,
hepsi muhteşem olmuş,
hangisini kullanacağımı şaşırdım, 

formülü ve diğer kodları şimdi ayrı ayrı 
nöbet listesinin aslına uygulamaya çalışacağım,

formül çok anlaşılır yalnız, kodları biraz uğraşacağım, belki yaparım.

Çalışmanızın tamamına vakıf değilim ama bence bir şablon sayfa oluşturup verileri oraya eklersiniz o sayfaya ekleyeceğiniz bir butonla ilgili sayfadaki yıla bakarak o yıla ait sayfa yoksa oluşturup varsa verilerin o yıla ait sayfaya eklenmesi sağlanabilir. Böylece verileriniz daha düzenli olur be işlem yapmak kolaylaşır.

---

Tabi şablon sayfadaki veriler silinecek

Yapmışken birde Dictionary yöntemiylede yapmış olalım
Makrolu kullanacaksanız ya bunu yada berduş hocamızın kodunu kullanabilirsiniz.Gerçi hepsi aynı sonucu veriyor bu daha hızlı yaptığım kodlar arasında.

@feraz bey

Alıntı:recordset bazen verileri almıyor

demiştiniz bir yorumunuzda, hangi durumlarda almıyor belli mi?