Aylık özet yoklama

[unur]

Arkadaşlar; İşyerinde günlük yoklama alıyoruz.Bunu ay sonunda aylık özet bir yoklama almak istiyoruz o ay için.Bu konuda örnek bir dosya ekledim.Yardımcı olursanız sevinirim.Teşekkürler.

 

[unur]

Bu konuda fikri olan arkadaş yokmu?

 

[unur]

Çokmu zor acaba konu; hiç kimse fikir beyan etmedi.

 

[Orion1]

Çokmu zor acaba konu; hiç kimse fikir beyan etmedi.

Zor değil,çerezlik.
Vakit sıkıntısı var.
Yarın bakarım.İyi geceler.

 

[unur]

Evren Bey Çok Teşekkür ederim. Şu çereze bir bakıverirseniz sevinirim.Teşekkürler

 

[Orion1]

Evren Bey Çok Teşekkür ederim. Şu çereze bir bakıverirseniz sevinirim.Teşekkürler

Merhaba.
Buyurun.Çitlemelik hazır.:keyif:
Dosyanız ektedir.
Kolay gelsin.

Option Base 1
Sub aylik_rapor_59()
Dim sh As Worksheet, z As Object, n As Double
Dim myarr(), i As Double, sat As Double, isim As String
'Date : 08.03.2011
'Coder : Evren Gizlen
'email : evrengizlen@hotmail.com
Sheets("özet").Select
Application.ScreenUpdating = False
Range("A2:G65536").Clear
Set z = CreateObject("scripting.dictionary")
ReDim myarr(1 To 6, 1 To 1)
For Each sh In Worksheets
    If IsNumeric(sh.Name) Then
        If Abs(CSng(sh.Name)) = CSng(sh.Name) And _
        CSng(sh.Name) >= 1 And CSng(sh.Name) <= 31 Then
            sat = sh.Cells(65536, "B").End(xlUp).Row
            If sat > 1 Then
                ReDim Preserve myarr(1 To 6, 1 To UBound(myarr, 2) + sat - 1)
                For i = 2 To sat
                    isim = UCase(Replace(Replace(sh.Cells(i, "B").Value, "i", "İ"), "ı", "I"))
                    If Not z.exists(isim) Then
                        n = n + 1
                        z.Add isim, n
                        myarr(1, n) = sh.Cells(i, "B").Value
                    End If
                    If UCase(sh.Cells(i, "C").Value) = "X" Then myarr(2, z.Item(isim)) = myarr(2, z.Item(isim)) + 1
                    If UCase(sh.Cells(i, "D").Value) = "X" Then myarr(3, z.Item(isim)) = myarr(3, z.Item(isim)) + 1
                    If UCase(sh.Cells(i, "E").Value) = "X" Then myarr(4, z.Item(isim)) = myarr(4, z.Item(isim)) + 1
                    If UCase(sh.Cells(i, "F").Value) = "X" Then myarr(5, z.Item(isim)) = myarr(5, z.Item(isim)) + 1
                    If UCase(sh.Cells(i, "G").Value) = "X" Then myarr(6, z.Item(isim)) = myarr(6, z.Item(isim)) + 1
                Next i
            End If
        End If
    End If
Next sh
Set z = Nothing
If n > 0 Then
    ReDim Preserve myarr(1 To 6, 1 To n)
    Range("B2").Resize(n, 6) = Application.Transpose(myarr)
    Erase myarr
    For i = 2 To n + 1
        Cells(i, "A").Value = i - 1
    Next
    Application.ScreenUpdating = True
    MsgBox "Rapor Çıkarıldı. :)" & vbLf & "C O D E R : Evren Gizlen" & vbLf & "Email : evrengizlen@hotmail.com"
Else
Application.ScreenUpdating = False
MsgBox "Kayıtlı Veri bulunamadı.", vbCritical, "U Y A R I"
End If
End Sub

 

[unur]

Evren Bey; Ellerinize sağlık, Emeğiniz için çok Teşekkürler.