Çalışma Planı Özetleme

[rahmiserif.oner]

Merhaba,

Bu mesaj ekindeki örnek dosyayı baz alarak yardımcı olursanız sevinirim.
Makrodan yapmasını istediğim;

1-Dosyada "ÖRNEK" olarak adlandırdığım listeyi otomatik olarak oluşturması.
2-Personellerin her birinin oluşan listede sadece bir defa olması
3-Ortalamaları alırken "-" olanları saymayarak ortalamayı hesaplaması. Yani kaç gün çalıştıysa ortalamayı ona göre hesaplaması

Şimdiden çok teşekkür ederim.

[SNNAY]

Deneyiniz. Sayfalarınızın sıralı olması gerekiyor 01.05 02.05 03.05 04.05 şeklinde eğer karışık ise Rapor sayfasında da karışık listeler.

Kod: Tümünü seç

Sub RaporOlustur()
    Dim ws As Worksheet
    Dim reportSheet As Worksheet
    Dim wsName As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim personelName As Variant
    Dim personelMaaş As Variant
    Dim colOffset As Long
    Dim personelDict As Object
    Dim uniqueNames As Collection
    Dim wsDates As Collection
    Dim colIndex As Long

    ' Rapor sayfasını oluştur
    On Error Resume Next
    Set reportSheet = ThisWorkbook.Worksheets("Rapor")
    On Error GoTo 0
    If reportSheet Is Nothing Then
        Set reportSheet = ThisWorkbook.Worksheets.Add
        reportSheet.Name = "Rapor"
    Else
        reportSheet.Cells.Clear
    End If

    ' Sözlük ve koleksiyon nesneleri oluştur
    Set personelDict = CreateObject("Scripting.Dictionary")
    Set uniqueNames = New Collection
    Set wsDates = New Collection

    ' Başlıkları ekle
    reportSheet.Cells(1, 1).Value = "PERSONEL"
    reportSheet.Cells(1, 1).Font.Bold = True

    ' Tüm çalışma sayfaları üzerinden geç ve tarihleri topla
    colOffset = 1
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsDate(wsName) Then
            wsDates.Add wsName
            colOffset = colOffset + 1
            reportSheet.Cells(1, colOffset).Value = wsName
            reportSheet.Cells(1, colOffset).Font.Bold = True
        End If
    Next ws

    ' Ortalama ve Genel Toplam başlıklarını ekle
    reportSheet.Cells(1, colOffset + 1).Value = "ORTALAMA"
    reportSheet.Cells(1, colOffset + 1).Font.Bold = True
    reportSheet.Cells(1, colOffset + 2).Value = "GENEL TOPLAM"
    reportSheet.Cells(1, colOffset + 2).Font.Bold = True

    ' Personel isimlerini ve maaşları topla
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsDate(wsName) Then
            For i = 3 To 22
                ' E sütunundaki ve I sütunundaki isimleri al
                For Each col In Array(5, 9)
                    personelName = ws.Cells(i, col).Value
                    personelMaaş = ws.Cells(i, 20).Value

                    If personelName <> "" Then
                        ' Yeni personel ismini kontrol et ve ekle
                        On Error Resume Next
                        uniqueNames.Add personelName, personelName
                        On Error GoTo 0

                        ' Personel ismini sözlüğe ekle veya güncelle
                        If Not personelDict.exists(personelName) Then
                            Set personelDict(personelName) = CreateObject("Scripting.Dictionary")
                        End If
                        personelDict(personelName)(wsName) = personelMaaş
                    End If
                Next col
            Next i
        End If
    Next ws
    ' Tarihleri sıralı bir şekilde topla
    Set wsDatesSorted = SortCollection(wsDates)

    ' Personel isimlerini ve maaşları rapor sayfasına yaz
    i = 2
    For Each personelName In uniqueNames
        reportSheet.Cells(i, 1).Value = personelName
        For j = 2 To wsDates.Count + 1
            wsName = reportSheet.Cells(1, j).Value
            If personelDict(personelName).exists(wsName) Then
                reportSheet.Cells(i, j).Value = personelDict(personelName)(wsName)
            End If
        Next j
        i = i + 1
    Next personelName

    ' Ortalama ve Genel Toplamları hesapla
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        reportSheet.Cells(i, colOffset + 1).Formula = "=AVERAGE(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
        reportSheet.Cells(i, colOffset + 2).Formula = "=SUM(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
    Next i

    ' Sütun genişliklerini ayarla
    reportSheet.Columns("A:Z").AutoFit

    ' İsimlere göre sırala
    reportSheet.Sort.SortFields.Clear
    reportSheet.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), Order:=xlAscending
    With reportSheet.Sort
        .SetRange Range("A1:" & Chr(65 + colOffset + 2) & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    MsgBox "Rapor oluşturuldu.", vbInformation
End Sub



Function SortCollection(col As Collection) As Collection
    Dim sortedCol As Collection
    Dim item As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

    Set sortedCol = New Collection
    For Each item In col
        sortedCol.Add item
    Next item

    For i = 1 To sortedCol.Count - 1
        For j = i + 1 To sortedCol.Count
            If CDate(sortedCol(i)) > CDate(sortedCol(j)) Then
                temp = sortedCol(j)
                sortedCol.Remove j
                sortedCol.Add temp, , i
            End If
        Next j
    Next i

    Set SortCollection = sortedCol
End Function


Sub QuickSort(arr As Variant, left As Long, right As Long)
    Dim i As Long, j As Long
    Dim pivot As Variant
    Dim temp As Variant
    
    i = left
    j = right
    pivot = arr((left + right) \ 2)
    
    While i <= j
        While arr(i) < pivot And i < right
            i = i + 1
        Wend
        
        While pivot < arr(j) And j > left
            j = j - 1
        Wend
        
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Wend
    
    If left < j Then QuickSort arr, left, j
    If i < right Then QuickSort arr, i, right
End Sub

[rahmiserif.oner]

Merhabalar,

Öncelikle emeğinize sağlık. Tam istediğim gibi çalışıyor. Fakat işlem sonunda "400" hatası veriyor "yanında kırmızı daire içinde çarpı olan" Bunu da çözebilir miyiz?

Teşekkürler.

[rahmiserif.oner]

Merhabalar,

Öncelikle emeğinize sağlık. Tam istediğim gibi çalışıyor. Fakat işlem sonunda "400" hatası veriyor "yanında kırmızı daire içinde çarpı olan" Bunu da çözebilir miyiz?

Teşekkürler.

Deneyiniz. Sayfalarınızın sıralı olması gerekiyor 01.05 02.05 03.05 04.05 şeklinde eğer karışık ise Rapor sayfasında da karışık listeler.

Kod: Tümünü seç

Sub RaporOlustur()
    Dim ws As Worksheet
    Dim reportSheet As Worksheet
    Dim wsName As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim personelName As Variant
    Dim personelMaaş As Variant
    Dim colOffset As Long
    Dim personelDict As Object
    Dim uniqueNames As Collection
    Dim wsDates As Collection
    Dim colIndex As Long

    ' Rapor sayfasını oluştur
    On Error Resume Next
    Set reportSheet = ThisWorkbook.Worksheets("Rapor")
    On Error GoTo 0
    If reportSheet Is Nothing Then
        Set reportSheet = ThisWorkbook.Worksheets.Add
        reportSheet.Name = "Rapor"
    Else
        reportSheet.Cells.Clear
    End If

    ' Sözlük ve koleksiyon nesneleri oluştur
    Set personelDict = CreateObject("Scripting.Dictionary")
    Set uniqueNames = New Collection
    Set wsDates = New Collection

    ' Başlıkları ekle
    reportSheet.Cells(1, 1).Value = "PERSONEL"
    reportSheet.Cells(1, 1).Font.Bold = True

    ' Tüm çalışma sayfaları üzerinden geç ve tarihleri topla
    colOffset = 1
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsDate(wsName) Then
            wsDates.Add wsName
            colOffset = colOffset + 1
            reportSheet.Cells(1, colOffset).Value = wsName
            reportSheet.Cells(1, colOffset).Font.Bold = True
        End If
    Next ws

    ' Ortalama ve Genel Toplam başlıklarını ekle
    reportSheet.Cells(1, colOffset + 1).Value = "ORTALAMA"
    reportSheet.Cells(1, colOffset + 1).Font.Bold = True
    reportSheet.Cells(1, colOffset + 2).Value = "GENEL TOPLAM"
    reportSheet.Cells(1, colOffset + 2).Font.Bold = True

    ' Personel isimlerini ve maaşları topla
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsDate(wsName) Then
            For i = 3 To 22
                ' E sütunundaki ve I sütunundaki isimleri al
                For Each col In Array(5, 9)
                    personelName = ws.Cells(i, col).Value
                    personelMaaş = ws.Cells(i, 20).Value

                    If personelName <> "" Then
                        ' Yeni personel ismini kontrol et ve ekle
                        On Error Resume Next
                        uniqueNames.Add personelName, personelName
                        On Error GoTo 0

                        ' Personel ismini sözlüğe ekle veya güncelle
                        If Not personelDict.exists(personelName) Then
                            Set personelDict(personelName) = CreateObject("Scripting.Dictionary")
                        End If
                        personelDict(personelName)(wsName) = personelMaaş
                    End If
                Next col
            Next i
        End If
    Next ws
    ' Tarihleri sıralı bir şekilde topla
    Set wsDatesSorted = SortCollection(wsDates)

    ' Personel isimlerini ve maaşları rapor sayfasına yaz
    i = 2
    For Each personelName In uniqueNames
        reportSheet.Cells(i, 1).Value = personelName
        For j = 2 To wsDates.Count + 1
            wsName = reportSheet.Cells(1, j).Value
            If personelDict(personelName).exists(wsName) Then
                reportSheet.Cells(i, j).Value = personelDict(personelName)(wsName)
            End If
        Next j
        i = i + 1
    Next personelName

    ' Ortalama ve Genel Toplamları hesapla
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        reportSheet.Cells(i, colOffset + 1).Formula = "=AVERAGE(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
        reportSheet.Cells(i, colOffset + 2).Formula = "=SUM(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
    Next i

    ' Sütun genişliklerini ayarla
    reportSheet.Columns("A:Z").AutoFit

    ' İsimlere göre sırala
    reportSheet.Sort.SortFields.Clear
    reportSheet.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), Order:=xlAscending
    With reportSheet.Sort
        .SetRange Range("A1:" & Chr(65 + colOffset + 2) & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    MsgBox "Rapor oluşturuldu.", vbInformation
End Sub



Function SortCollection(col As Collection) As Collection
    Dim sortedCol As Collection
    Dim item As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

    Set sortedCol = New Collection
    For Each item In col
        sortedCol.Add item
    Next item

    For i = 1 To sortedCol.Count - 1
        For j = i + 1 To sortedCol.Count
            If CDate(sortedCol(i)) > CDate(sortedCol(j)) Then
                temp = sortedCol(j)
                sortedCol.Remove j
                sortedCol.Add temp, , i
            End If
        Next j
    Next i

    Set SortCollection = sortedCol
End Function


Sub QuickSort(arr As Variant, left As Long, right As Long)
    Dim i As Long, j As Long
    Dim pivot As Variant
    Dim temp As Variant
    
    i = left
    j = right
    pivot = arr((left + right) \ 2)
    
    While i <= j
        While arr(i) < pivot And i < right
            i = i + 1
        Wend
        
        While pivot < arr(j) And j > left
            j = j - 1
        Wend
        
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Wend
    
    If left < j Then QuickSort arr, left, j
    If i < right Then QuickSort arr, i, right
End Sub

[SNNAY]

Örnek dosyanızda hata vermemişti. Büyük ihtimalle sayfa isimleri ile alakalıdır. Hatalı sayfa adları olabilir. Bu kodu deneyiniz. Hata veriyorsa tam olarak hangi satırda hata verdiğini belirtiniz.

Kod: Tümünü seç

Sub RaporOlustur()
    Dim ws As Worksheet
    Dim reportSheet As Worksheet
    Dim wsName As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim personelName As Variant
    Dim personelMaaş As Variant
    Dim colOffset As Long
    Dim personelDict As Object
    Dim uniqueNames As Collection
    Dim wsDates As Collection
    Dim colIndex As Long

    ' Rapor sayfasını oluştur
    On Error Resume Next
    Set reportSheet = ThisWorkbook.Worksheets("Rapor")
    On Error GoTo 0
    If reportSheet Is Nothing Then
        Set reportSheet = ThisWorkbook.Worksheets.Add
        reportSheet.Name = "Rapor"
    Else
        reportSheet.Cells.Clear
    End If

    ' Sözlük ve koleksiyon nesneleri oluştur
    Set personelDict = CreateObject("Scripting.Dictionary")
    Set uniqueNames = New Collection
    Set wsDates = New Collection

    ' Başlıkları ekle
    reportSheet.Cells(1, 1).Value = "PERSONEL"
    reportSheet.Cells(1, 1).Font.Bold = True

    ' Tüm çalışma sayfaları üzerinden geç ve tarihleri topla
    colOffset = 1
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(wsName) Then
            wsDates.Add wsName
            colOffset = colOffset + 1
            reportSheet.Cells(1, colOffset).Value = wsName
            reportSheet.Cells(1, colOffset).Font.Bold = True
        End If
    Next ws

    ' Ortalama ve Genel Toplam başlıklarını ekle
    reportSheet.Cells(1, colOffset + 1).Value = "ORTALAMA"
    reportSheet.Cells(1, colOffset + 1).Font.Bold = True
    reportSheet.Cells(1, colOffset + 2).Value = "GENEL TOPLAM"
    reportSheet.Cells(1, colOffset + 2).Font.Bold = True

    ' Personel isimlerini ve maaşları topla
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(wsName) Then
            For i = 3 To 22
                ' E sütunundaki ve I sütunundaki isimleri al
                For Each col In Array(5, 9)
                    personelName = ws.Cells(i, col).Value
                    personelMaaş = ws.Cells(i, 20).Value

                    If personelName <> "" Then
                        ' Yeni personel ismini kontrol et ve ekle
                        On Error Resume Next
                        uniqueNames.Add personelName, personelName
                        On Error GoTo 0

                        ' Personel ismini sözlüğe ekle veya güncelle
                        If Not personelDict.exists(personelName) Then
                            Set personelDict(personelName) = CreateObject("Scripting.Dictionary")
                        End If
                        personelDict(personelName)(wsName) = personelMaaş
                    End If
                Next col
            Next i
        End If
    Next ws

    ' Personel isimlerini ve maaşları rapor sayfasına yaz
    i = 2
    For Each personelName In uniqueNames
        reportSheet.Cells(i, 1).Value = personelName
        For j = 2 To wsDates.Count + 1
            wsName = reportSheet.Cells(1, j).Value
            If personelDict(personelName).exists(wsName) Then
                reportSheet.Cells(i, j).Value = personelDict(personelName)(wsName)
            End If
        Next j
        i = i + 1
    Next personelName

    ' Ortalama ve Genel Toplamları hesapla
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        reportSheet.Cells(i, colOffset + 1).Formula = "=AVERAGE(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
        reportSheet.Cells(i, colOffset + 2).Formula = "=SUM(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
    Next i

    ' Sütun genişliklerini ayarla
    reportSheet.Columns("A:Z").AutoFit

    ' İsimlere göre sırala
    reportSheet.Sort.SortFields.Clear
    reportSheet.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), Order:=xlAscending
    With reportSheet.Sort
        .SetRange Range("A1:" & Chr(65 + colOffset + 2) & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    MsgBox "Rapor oluşturuldu.", vbInformation
End Sub

Function IsValidDate(dateStr As String) As Boolean
    On Error GoTo InvalidDate
    IsValidDate = IsDate(CDate(dateStr))
    Exit Function
InvalidDate:
    IsValidDate = False
End Function

Function SortCollection(col As Collection) As Collection
    Dim sortedCol As Collection
    Dim item As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

    Set sortedCol = New Collection
    For Each item In col
        sortedCol.Add item
    Next item

    For i = 1 To sortedCol.Count - 1
        For j = i + 1 To sortedCol.Count
            If CDate(sortedCol(i)) > CDate(sortedCol(j)) Then
                temp = sortedCol(j)
                sortedCol.Remove j
                sortedCol.Add temp, , i
            End If
        Next j
    Next i

    Set SortCollection = sortedCol
End Function

[rahmiserif.oner]

İlk gönderdiğinizde hata veriyor fakat rapor sayfasını oluşturuyordu. Bu son gönderdiğiniz ise ekteki resimde belirttiğim kısımda hata verdi.

Örnek dosyanızda hata vermemişti. Büyük ihtimalle sayfa isimleri ile alakalıdır. Hatalı sayfa adları olabilir. Bu kodu deneyiniz. Hata veriyorsa tam olarak hangi satırda hata verdiğini belirtiniz.

Kod: Tümünü seç

Sub RaporOlustur()
    Dim ws As Worksheet
    Dim reportSheet As Worksheet
    Dim wsName As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim personelName As Variant
    Dim personelMaaş As Variant
    Dim colOffset As Long
    Dim personelDict As Object
    Dim uniqueNames As Collection
    Dim wsDates As Collection
    Dim colIndex As Long

    ' Rapor sayfasını oluştur
    On Error Resume Next
    Set reportSheet = ThisWorkbook.Worksheets("Rapor")
    On Error GoTo 0
    If reportSheet Is Nothing Then
        Set reportSheet = ThisWorkbook.Worksheets.Add
        reportSheet.Name = "Rapor"
    Else
        reportSheet.Cells.Clear
    End If

    ' Sözlük ve koleksiyon nesneleri oluştur
    Set personelDict = CreateObject("Scripting.Dictionary")
    Set uniqueNames = New Collection
    Set wsDates = New Collection

    ' Başlıkları ekle
    reportSheet.Cells(1, 1).Value = "PERSONEL"
    reportSheet.Cells(1, 1).Font.Bold = True

    ' Tüm çalışma sayfaları üzerinden geç ve tarihleri topla
    colOffset = 1
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(wsName) Then
            wsDates.Add wsName
            colOffset = colOffset + 1
            reportSheet.Cells(1, colOffset).Value = wsName
            reportSheet.Cells(1, colOffset).Font.Bold = True
        End If
    Next ws

    ' Ortalama ve Genel Toplam başlıklarını ekle
    reportSheet.Cells(1, colOffset + 1).Value = "ORTALAMA"
    reportSheet.Cells(1, colOffset + 1).Font.Bold = True
    reportSheet.Cells(1, colOffset + 2).Value = "GENEL TOPLAM"
    reportSheet.Cells(1, colOffset + 2).Font.Bold = True

    ' Personel isimlerini ve maaşları topla
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(wsName) Then
            For i = 3 To 22
                ' E sütunundaki ve I sütunundaki isimleri al
                For Each col In Array(5, 9)
                    personelName = ws.Cells(i, col).Value
                    personelMaaş = ws.Cells(i, 20).Value

                    If personelName <> "" Then
                        ' Yeni personel ismini kontrol et ve ekle
                        On Error Resume Next
                        uniqueNames.Add personelName, personelName
                        On Error GoTo 0

                        ' Personel ismini sözlüğe ekle veya güncelle
                        If Not personelDict.exists(personelName) Then
                            Set personelDict(personelName) = CreateObject("Scripting.Dictionary")
                        End If
                        personelDict(personelName)(wsName) = personelMaaş
                    End If
                Next col
            Next i
        End If
    Next ws

    ' Personel isimlerini ve maaşları rapor sayfasına yaz
    i = 2
    For Each personelName In uniqueNames
        reportSheet.Cells(i, 1).Value = personelName
        For j = 2 To wsDates.Count + 1
            wsName = reportSheet.Cells(1, j).Value
            If personelDict(personelName).exists(wsName) Then
                reportSheet.Cells(i, j).Value = personelDict(personelName)(wsName)
            End If
        Next j
        i = i + 1
    Next personelName

    ' Ortalama ve Genel Toplamları hesapla
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        reportSheet.Cells(i, colOffset + 1).Formula = "=AVERAGE(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
        reportSheet.Cells(i, colOffset + 2).Formula = "=SUM(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
    Next i

    ' Sütun genişliklerini ayarla
    reportSheet.Columns("A:Z").AutoFit

    ' İsimlere göre sırala
    reportSheet.Sort.SortFields.Clear
    reportSheet.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), Order:=xlAscending
    With reportSheet.Sort
        .SetRange Range("A1:" & Chr(65 + colOffset + 2) & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    MsgBox "Rapor oluşturuldu.", vbInformation
End Sub

Function IsValidDate(dateStr As String) As Boolean
    On Error GoTo InvalidDate
    IsValidDate = IsDate(CDate(dateStr))
    Exit Function
InvalidDate:
    IsValidDate = False
End Function

Function SortCollection(col As Collection) As Collection
    Dim sortedCol As Collection
    Dim item As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

    Set sortedCol = New Collection
    For Each item In col
        sortedCol.Add item
    Next item

    For i = 1 To sortedCol.Count - 1
        For j = i + 1 To sortedCol.Count
            If CDate(sortedCol(i)) > CDate(sortedCol(j)) Then
                temp = sortedCol(j)
                sortedCol.Remove j
                sortedCol.Add temp, , i
            End If
        Next j
    Next i

    Set SortCollection = sortedCol
End Function

[SNNAY]

Deneyiniz

Kod: Tümünü seç

Sub RaporOlustur()
    Dim ws As Worksheet
    Dim reportSheet As Worksheet
    Dim wsName As String
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim personelName As Variant
    Dim personelMaaş As Variant
    Dim colOffset As Long
    Dim personelDict As Object
    Dim uniqueNames As Collection
    Dim wsDates As Collection
    Dim colIndex As Long

    ' Rapor sayfasını oluştur
    On Error Resume Next
    Set reportSheet = ThisWorkbook.Worksheets("Rapor")
    On Error GoTo 0
    If reportSheet Is Nothing Then
        Set reportSheet = ThisWorkbook.Worksheets.Add
        reportSheet.Name = "Rapor"
    Else
        reportSheet.Cells.Clear
    End If

    ' Sözlük ve koleksiyon nesneleri oluştur
    Set personelDict = CreateObject("Scripting.Dictionary")
    Set uniqueNames = New Collection
    Set wsDates = New Collection

    ' Başlıkları ekle
    reportSheet.Cells(1, 1).Value = "PERSONEL"
    reportSheet.Cells(1, 1).Font.Bold = True

    ' Tüm çalışma sayfaları üzerinden geç ve tarihleri topla
    colOffset = 1
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(CStr(wsName)) Then
            wsDates.Add wsName
            colOffset = colOffset + 1
            reportSheet.Cells(1, colOffset).Value = wsName
            reportSheet.Cells(1, colOffset).Font.Bold = True
        End If
    Next ws

    ' Ortalama ve Genel Toplam başlıklarını ekle
    reportSheet.Cells(1, colOffset + 1).Value = "ORTALAMA"
    reportSheet.Cells(1, colOffset + 1).Font.Bold = True
    reportSheet.Cells(1, colOffset + 2).Value = "GENEL TOPLAM"
    reportSheet.Cells(1, colOffset + 2).Font.Bold = True

    ' Personel isimlerini ve maaşları topla
    For Each ws In ThisWorkbook.Worksheets
        wsName = ws.Name
        If IsValidDate(CStr(wsName)) Then
            For i = 3 To 22
                ' E sütunundaki ve I sütunundaki isimleri al
                For Each col In Array(5, 9)
                    personelName = ws.Cells(i, col).Value
                    personelMaaş = ws.Cells(i, 20).Value

                    If personelName <> "" Then
                        ' Yeni personel ismini kontrol et ve ekle
                        On Error Resume Next
                        uniqueNames.Add personelName, personelName
                        On Error GoTo 0

                        ' Personel ismini sözlüğe ekle veya güncelle
                        If Not personelDict.exists(personelName) Then
                            Set personelDict(personelName) = CreateObject("Scripting.Dictionary")
                        End If
                        personelDict(personelName)(wsName) = personelMaaş
                    End If
                Next col
            Next i
        End If
    Next ws

    ' Personel isimlerini ve maaşları rapor sayfasına yaz
    i = 2
    For Each personelName In uniqueNames
        reportSheet.Cells(i, 1).Value = personelName
        For j = 2 To wsDates.Count + 1
            wsName = reportSheet.Cells(1, j).Value
            If personelDict(personelName).exists(wsName) Then
                reportSheet.Cells(i, j).Value = personelDict(personelName)(wsName)
            End If
        Next j
        i = i + 1
    Next personelName

    ' Ortalama ve Genel Toplamları hesapla
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        reportSheet.Cells(i, colOffset + 1).Formula = "=AVERAGE(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
        reportSheet.Cells(i, colOffset + 2).Formula = "=SUM(B" & i & ":" & Chr(65 + colOffset - 1) & i & ")"
    Next i

    ' Sütun genişliklerini ayarla
    reportSheet.Columns("A:Z").AutoFit

    ' İsimlere göre sırala
    reportSheet.Sort.SortFields.Clear
    reportSheet.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), Order:=xlAscending
    With reportSheet.Sort
        .SetRange Range("A1:" & Chr(65 + colOffset + 2) & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    MsgBox "Rapor oluşturuldu.", vbInformation
End Sub

Function IsValidDate(dateStr As String) As Boolean
    On Error GoTo InvalidDate
    IsValidDate = IsDate(CDate(dateStr))
    Exit Function
InvalidDate:
    IsValidDate = False
End Function

Function SortCollection(col As Collection) As Collection
    Dim sortedCol As Collection
    Dim item As Variant
    Dim i As Long, j As Long
    Dim temp As Variant

    Set sortedCol = New Collection
    For Each item In col
        sortedCol.Add item
    Next item

    For i = 1 To sortedCol.Count - 1
        For j = i + 1 To sortedCol.Count
            If CDate(sortedCol(i)) > CDate(sortedCol(j)) Then
                temp = sortedCol(j)
                sortedCol.Remove j
                sortedCol.Add temp, , i
            End If
        Next j
    Next i

    Set SortCollection = sortedCol
End Function