Çalışma Planı Özetleme

Cevapla
rahmiserif.oner
Mesajlar: 4
Kayıt: Çrş Haz 12, 2024 12:12 pm
Lokasyon: istanbul
Meslek: Elektrik Teknikeri
Adınız: Rahmi Şerif
Soyadınız: Öner

Çalışma Planı Özetleme

Mesaj gönderen 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.
Bu mesaja eklenen dosyaları görüntülemek için gerekli izinlere sahip değilsiniz.
SNNAY
Mesajlar: 29
Kayıt: Prş Mar 21, 2024 11:31 am
Lokasyon: istanbul
Meslek: Oto Yedek Parça Satış Elemanı
Adınız: Sinan
Soyadınız: Aykaç

Re: Çalışma Planı Özetleme

Mesaj gönderen 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

Bu mesaja eklenen dosyaları görüntülemek için gerekli izinlere sahip değilsiniz.
rahmiserif.oner
Mesajlar: 4
Kayıt: Çrş Haz 12, 2024 12:12 pm
Lokasyon: istanbul
Meslek: Elektrik Teknikeri
Adınız: Rahmi Şerif
Soyadınız: Öner

Re: Çalışma Planı Özetleme

Mesaj gönderen 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
Mesajlar: 4
Kayıt: Çrş Haz 12, 2024 12:12 pm
Lokasyon: istanbul
Meslek: Elektrik Teknikeri
Adınız: Rahmi Şerif
Soyadınız: Öner

Re: Çalışma Planı Özetleme

Mesaj gönderen 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.

SNNAY yazdı: Çrş Haz 12, 2024 7:40 pm 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

Bu mesaja eklenen dosyaları görüntülemek için gerekli izinlere sahip değilsiniz.
SNNAY
Mesajlar: 29
Kayıt: Prş Mar 21, 2024 11:31 am
Lokasyon: istanbul
Meslek: Oto Yedek Parça Satış Elemanı
Adınız: Sinan
Soyadınız: Aykaç

Re: Çalışma Planı Özetleme

Mesaj gönderen 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
Mesajlar: 4
Kayıt: Çrş Haz 12, 2024 12:12 pm
Lokasyon: istanbul
Meslek: Elektrik Teknikeri
Adınız: Rahmi Şerif
Soyadınız: Öner

Re: Çalışma Planı Özetleme

Mesaj gönderen 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.



SNNAY yazdı: Prş Haz 13, 2024 1:05 pm Ö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
Bu mesaja eklenen dosyaları görüntülemek için gerekli izinlere sahip değilsiniz.
SNNAY
Mesajlar: 29
Kayıt: Prş Mar 21, 2024 11:31 am
Lokasyon: istanbul
Meslek: Oto Yedek Parça Satış Elemanı
Adınız: Sinan
Soyadınız: Aykaç

Re: Çalışma Planı Özetleme

Mesaj gönderen 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
Cevapla