Skip to main content

AccessTr.neT


Nöbet Tutanların Hafta İçi Ve Hafta Sonu Sayısını Hesaplama

Nöbet Tutanların Hafta İçi Ve Hafta Sonu Sayısını Hesaplama

Çözüldü #1
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][Resim: do.php?img=10427][/img]
.rar nöbet hesap listesi.rar (Dosya Boyutu: 3,51 KB | İndirme Sayısı: 8)
husem, proud to be a member of AccessTr.neT since 08-03-2009.
Cevapla
#2
Deneyiniz kod ile yaptım.



[Resim: do.php?img=10429]



Visual Basic Code
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

.rar nöbet hesap listesi.rar (Dosya Boyutu: 16,75 KB | İndirme Sayısı: 8)
Cevapla
#3
@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ı?
Cevapla
#4
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.
Cevapla
#5
Alttaki kod daha iyi.
Not:Kod güncellendi....



Visual Basic Code
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

.rar nöbet hesap listesi1.rar (Dosya Boyutu: 16,89 KB | İndirme Sayısı: 0)
Cevapla
#6
Buda union ile yapıldı istenilen sütunlar eklenebilir koda.

Visual Basic Code
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

.rar nöbet hesap listesi2.rar (Dosya Boyutu: 17,09 KB | İndirme Sayısı: 1)
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da