AccessTr.neT

merhaba arkadaşlar,
yıl içinde kişilerin tuttukları nöbetleri hafta içi ve hafta sonu olarak toplatmak istiyorum.

aşağıda örnek olarak hazırlanan Ağustos ve Eylül listesi var. bu listede kişilerin tuttukları nöbetleri hafta içi ve hafta sonu olarak sayılarını sağ taraftaki alanda kişilerin karşısında toplatmak istiyorum. nasıl bir formül yapılabilir acaba?

[img][/img]

Deneyiniz kod ile yaptım.

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

@feraz bey bu sadece girilen 2 ay için değil mi?
Yıllık veri girildiğinde bu şablon sorun çıkarmaz mi? Bu durumda ayların yatay değil de dikey girilmesi daha uygun olmaz mı?

Sadece iki aylık.Evet dikey yani alt alta olsaydı hem kod kısa olurdu hemde mantıklı olurdu.Tabii kullanıcı böyle istemiş vardır bir bildiği üstadım.

Alttaki kod daha iyi.
Not:Kod güncellendi....

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 Sub

Buda union ile yapıldı istenilen sütunlar eklenebilir koda.

Private 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