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

Not: 2 yöntemde farklı sonuçlar veriyor. İyice kontrol etmenizde fayda var

Berduş hocam sizin kod bazılarında hata veriyor.
ayşe olarak denedim bende 5 hafta içi 2 hafta sonu çıktı.
sizde 4 ve 3 olarak çıktı.isterseniz bir inceleyin.

Denemeniz için formülle yaptım gerçi biraz uzun oldu.Dosyayı ekliyorum resimdede gösterdim.Yani berduş hocam sizinki hatalı diye düşünüyorum.
Formülleri denemek için Ev eF sütunlarında yaptım.



E3 Formülü;

=TOPLA.ÇARPIM((Ocak!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ocak!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Şubat!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Şubat!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Mart!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Mart!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Nisan!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Nisan!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Mayıs!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Mayıs!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Haziran!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Haziran!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Temmuz!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Temmuz!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Ağustos!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ağustos!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Eylül!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Eylül!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Ekim!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ekim!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Kasım!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Kasım!$A$3:$A$33;2)<6))+TOPLA.ÇARPIM((Aralık!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Aralık!$A$3:$A$33;2)<6))

F3 formülü;

=TOPLA.ÇARPIM((Ocak!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ocak!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Şubat!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Şubat!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Mart!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Mart!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Nisan!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Nisan!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Mayıs!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Mayıs!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Haziran!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Haziran!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Temmuz!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Temmuz!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Ağustos!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ağustos!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Eylül!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Eylül!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Ekim!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Ekim!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Kasım!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Kasım!$A$3:$A$33;2)>5))+TOPLA.ÇARPIM((Aralık!$B$3:$B$33=$A3)*(HAFTANINGÜNÜ(Aralık!$A$3:$A$33;2)>5))

(17/07/2020, 15:40)feraz yazdı: Berduş hocam sizin kod bazılarında hata veriyor.

haklısınız hatalı olan benim dosya weekday(Trh) fonksiyonun gün parametresi girmeyi unuttuğumdan yanlış hesaplıyormuş
dogrusu weekday(Trh,2) şeklinde olmalıydı. düzeltilmiş kod:

        Application.ScreenUpdating = False

Dim SQL, TbU As String



Dim ADO_RS As ADODB.Recordset

Dim ADO_CN As ADODB.Connection

    

'Hafta ici bulmak icin

    With ActiveSheet

        .Range("A3:C" & Rows.Count).ClearContents

        For Each syf In Worksheets

            If syf.Name <> .Name Then

            TbU = TbU & "Union all " & "SELECT F1 as NobetTrh, F2 as Nobetci FROM [" & syf.Name & "$A3:B] "

            End If

        Next

    

    End With

    TbU = Mid(TbU, 11)



SQL = "SELECT TbU.Nobetci, Sum(IIf(Weekday([NobetTrh],2)<6,1,0)) AS Hftici, Sum(IIf(Weekday([NobetTrh],2)>5,1,0)) AS HftSon " & _

      "FROM(" & TbU & ")  As TbU " & _

      "GROUP BY TbU.Nobetci " & _

      "HAVING (((TbU.Nobetci)<>''));"



Set ADO_RS = New ADODB.Recordset

Set ADO_CN = New ADODB.Connection



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""

ADO_CN.Open

ADO_RS.Open SQL, ADO_CN, 3, 1

'

'  Eğer Hiç Kayıt Yoksa

If ADO_RS.RecordCount = 0 Then

    ADO_RS.Close

    ADO_CN.Close

    Set ADO_RS = Nothing

    Set ADO_CN = Nothing

    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

    Exit Sub

    End If

ADO_RS.MoveLast

ADO_RS.MoveFirst

 Sheets("Toplam Liste").Range("A3").CopyFromRecordset ADO_RS



' ComboBox1.Column = ADO_RS.GetRows



ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing

son:

        Application.ScreenUpdating = True



End Sub

Evet üstad böyle harika olmuş Formüllü olarakta eklendi artık

(17/07/2020, 16:20)berduş yazdı:

(17/07/2020, 15:40)feraz yazdı: Berduş hocam sizin kod bazılarında hata veriyor.

haklısınız hatalı olan benim dosya weekday(Trh) fonksiyonun gün parametresi girmeyi unuttuğumdan yanlış hesaplıyormuş
dogrusu weekday(Trh,2) şeklinde olmalıydı. düzeltilmiş kod:

        Application.ScreenUpdating = False

Dim SQL, TbU As String



Dim ADO_RS As ADODB.Recordset

Dim ADO_CN As ADODB.Connection

    

'Hafta ici bulmak icin

    With ActiveSheet

        .Range("A3:C" & Rows.Count).ClearContents

        For Each syf In Worksheets

            If syf.Name <> .Name Then

            TbU = TbU & "Union all " & "SELECT F1 as NobetTrh, F2 as Nobetci FROM [" & syf.Name & "$A3:B] "

            End If

        Next

    

    End With

    TbU = Mid(TbU, 11)



SQL = "SELECT TbU.Nobetci, Sum(IIf(Weekday([NobetTrh],2)<6,1,0)) AS Hftici, Sum(IIf(Weekday([NobetTrh],2)>5,1,0)) AS HftSon " & _

      "FROM(" & TbU & ")  As TbU " & _

      "GROUP BY TbU.Nobetci " & _

      "HAVING (((TbU.Nobetci)<>''));"



Set ADO_RS = New ADODB.Recordset

Set ADO_CN = New ADODB.Connection



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""

ADO_CN.Open

ADO_RS.Open SQL, ADO_CN, 3, 1

'

'  Eğer Hiç Kayıt Yoksa

If ADO_RS.RecordCount = 0 Then

    ADO_RS.Close

    ADO_CN.Close

    Set ADO_RS = Nothing

    Set ADO_CN = Nothing

    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

    Exit Sub

    End If

ADO_RS.MoveLast

ADO_RS.MoveFirst

 Sheets("Toplam Liste").Range("A3").CopyFromRecordset ADO_RS



' ComboBox1.Column = ADO_RS.GetRows



ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing

son:

        Application.ScreenUpdating = True



End Sub

@berduş hocam kodunuzu alttaki gibi düzenledim izninizle.

Private Sub btnAktar_Click()

        

    Dim Sql As String, TbU As String

    

    Dim ADO_RS As New ADODB.Recordset

    Dim ADO_CN As New ADODB.Connection

        

    With Sheets("Toplam Liste")

        .Range("A3:C" & Rows.Count).ClearContents

        For Each syf In Worksheets

            If syf.Name <> .Name Then

                TbU = TbU & "Union all " & "SELECT F1 as NobetTrh, F2 as Nobetci FROM [" & syf.Name & "$A3:B] "

            End If

        Next

        

        TbU = Mid(TbU, 11)

            

        Sql = "SELECT TbU.Nobetci, Sum(IIf(Weekday([NobetTrh],2)<6,1,0)) AS Hftici, Sum(IIf(Weekday([NobetTrh],2)>5,1,0)) AS HftSon " & _

              "FROM(" & TbU & ")  As TbU " & _

              "GROUP BY TbU.Nobetci " & _

              "HAVING (((TbU.Nobetci)<>''));"

        

        ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""

        ADO_CN.Open

        ADO_RS.Open SQL, ADO_CN, 1, 1

        

        If ADO_RS.RecordCount > 0 Then

            .Range("A3").CopyFromRecordset ADO_RS

            MsgBox "Aktarildi...", vbInformation, "Bilgi"

            GoTo var

        Else

            MsgBox "Kayýt Bulunamadý.", vbCritical, "Veri Yok"

            GoTo var

        End If

    End With

var:

    ADO_RS.Close

    ADO_CN.Close

    Set ADO_RS = Nothing

    Set ADO_CN = Nothing

End Sub