puantaja veri aktarma

[cemre1970]

Selamlar Kolay gelsin.
Ekteki dosyada günlük olarak tuttuğum yevmiye kayıtları var. Ay ortası veya sonunda puantaja aktaran bir kod yazılabilir mi?
Yardımlarınız için şimdiden teşekkürler

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod işinizi görebilir. İnceleyiniz.

Option Explicit
Sub Kumulatif_Puantaj()
    Dim sh As Worksheet
    Dim shP As Worksheet
    Dim colA As New Collection
    Dim colP As New Collection
    Dim rg As Range
    Dim hcr As Range
    Dim bul As Range
    Dim r%, i%, j%, z%, m%, b%, e%, sutun%
    Dim adres As String
    
    Set shP = Sheets("PUANTAJ")
    shP.Cells.Clear
    
    On Error Resume Next
    r = 2
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shP.Name Then
            For i = 2 To sh.Cells(65536, 2).End(xlUp).Row
                colA.Add sh.Cells(i, 2), sh.Cells(i, 2)
                colP.Add sh.Cells(i, 4), sh.Cells(i, 4)
            Next i
            r = r + 1
            shP.Cells(r, 1) = "'" & sh.Name
        End If
    Next
    
    On Error GoTo 0
    
    For i = 1 To colA.Count
        With shP
            With .Cells(1, i + 1)
                .Value = colA.Item(i)
                .Orientation = 90
            End With
            .Columns(i + 1).ColumnWidth = 2.43
        End With
    Next i
    
    For j = 1 To colP.Count
        With shP
            With .Cells(1, i + 1)
                .Value = colP.Item(j)
                .Orientation = 90
            End With
            .Columns(i).ColumnWidth = 2.43
            .Columns(i + 1).ColumnWidth = 2.43
            .Cells(2, i + 1) = "B": .Cells(2, i + 2) = "E"
            i = i + 2
        End With
    Next j
    
    shP.Columns(i).ColumnWidth = 2.43
    shP.Cells(1, 1) = "ADI SOYADI"
    shP.Cells(2, 1) = "TARİH"
    
    i = 2
    
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shP.Name Then
            i = i + 1
                For j = 2 To colA.Count + 1
                    Set bul = sh.Columns(2).Find(shP.Cells(1, j), Lookat:=xlWhole)
                    If Not bul Is Nothing Then
                        shP.Cells(i, j) = sh.Cells(bul.Row, "F")
                    End If
                Next j
        
            z = colA.Count + 2
            
            For m = 1 To colP.Count
                Set bul = sh.Columns(4).Find(colP.Item(m), Lookat:=xlWhole)
                If Not bul Is Nothing Then
                    adres = bul.Address
                    Do
                        If sh.Cells(bul.Row, 3) = "B" Then: b = b + 1
                        If sh.Cells(bul.Row, 3) = "E" Then: e = e + 1
                        Set bul = sh.Columns(4).FindNext(bul)
                    Loop While Not bul Is Nothing And adres <> bul.Address
                    shP.Cells(i, z) = b
                    shP.Cells(i, z + 1) = e
                    b = 0: e = 0
                    z = z + 2
                End If
            Next m
        
        End If
    Next
    
    For j = 2 To shP.Range("IV1").End(xlToLeft).Column + 1
        shP.Cells(shP.Cells(65536, 1).End(xlUp).Row + 2, j).Formula = _
                                            "=SUM(" & shP.Cells(3, j).Address & ":" & _
                                              shP.Cells(shP.Cells(65536, 1).End(xlUp).Row, j).Address & ")"
    Next j
    
    shP.Cells(shP.Cells(65536, 1).End(xlUp).Row + 2, 1) = "GÜNLÜK"
    
    With shP
         sutun = .Range("IV2").End(xlToLeft).Column + 1
        .Cells(1, sutun) = "TOPLAM": .Cells(2, sutun) = "B": .Cells(2, sutun + 1) = "E"
        .Cells(1, sutun + 2) = "GENEL TOPLAM"
        .Cells(1, sutun).Orientation = 90: .Cells(1, sutun + 2).Orientation = 90
        .Columns(sutun).ColumnWidth = 2.43: .Columns(sutun + 1).ColumnWidth = 2.43
        .Columns(sutun + 2).ColumnWidth = 2.43
    End With
    
    For i = 3 To shP.Cells(65536, 1).End(xlUp).Row - 2
        shP.Cells(i, sutun).Formula = _
                            "=SUMIF(" & shP.Cells(2, colA.Count + 2).Address & ":" & _
                            shP.Cells(2, sutun - 1).Address & "," & _
                            shP.Cells(2, sutun).Address & "," & _
                            shP.Cells(i, colA.Count + 2).Address & ":" & _
                            shP.Cells(i, sutun - 1).Address & ")"
        shP.Cells(i, sutun + 1).Formula = _
                            "=SUMIF(" & shP.Cells(2, colA.Count + 2).Address & ":" & _
                            shP.Cells(2, sutun - 1).Address & "," & _
                            shP.Cells(2, sutun + 1).Address & "," & _
                            shP.Cells(i, colA.Count + 2).Address & ":" & _
                            shP.Cells(i, sutun - 1).Address & ")"
        shP.Cells(i, sutun + 2).Formula = _
                            "=" & shP.Cells(i, sutun).Address & "+" & _
                                  shP.Cells(i, sutun + 1).Address
    Next i
        
    Set bul = Nothing
    Set shP = Nothing
End Sub

Ekte düzenlenen dosyanızı inceleyiniz.

 

[cemre1970]

çok teşekkürler. tam istediğim gibi olmuş