Tazminat Puantaj Çalışması

[aligunes]

Ekte sunduğum tazminat puantaj hazırlama çalışmasında FORMÜL yada MAKRO kullanarak yapmak istiyorum çalışmaya katkı sunacak arkadaşlara ve değerli hocalara şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

Bu işi formül ile değil makro ile yapmanız daha doğru olacaktır. Tekrar eden isimler, şarta göre tek hücrede birleştirilecek veriler vs. makroya daha uygun.

 

[aligunes]

doğru makro ile olur ben de öyle düşünüyorum bu çalışmayı MAKRO ile yapmaya yardım edecek değerli hocalardan yardım bekliyorum

 

[ckarabacak]

Sn. aligunes Merhaba

Aylık Tazminat ifadenizden şunumu anlamalıyız. Kişi veya kişilerin Aylık çalışma puantajı olarak mı düşünmeliyiz yoksa farklı bir çalışmamı, Aylık Tazminat Terimini çalışma hayatında sizin ilk defa ifade etmenizden ne anlamalıyız ki ona göre mantık yürütelim ve size örnek dosya veya dosyalar gönderebilelim. Zira Tazminat ifadesi çalışma hayatında belli bir süre çalışılması sonucunda koşullara uygun olması halinde yapılan toplu ödemedir.

 

[Ömer]

Deneyiniz.

Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, d As Object
 
    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Lİste")
 
    Application.ScreenUpdating = False
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "B").End(xlUp).Row
    Range("D4:AH" & son).ClearContents
 
    trh = DateSerial(Year("1." & [AI2]), Month("1." & [AI2]) + 1, 0)
    gun = Day(trh)
 
    For i = 4 To son
        Cells(i, "D").Resize(1, gun) = "x"
        Set c = Si.[A:A].Find(Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                bsl = Si.Cells(c.Row, "C")
                bts = Si.Cells(c.Row, "E")
                If bts > 0 Then
                    If Si.Cells(c.Row, "D") > trh Then bts = trh - bsl - 1
                    If Format(bsl, "MMMM") = WorksheetFunction.Proper(UCase(Replace(Replace([AI2], _
                        "ı", "I"), "i", "İ"))) Then
                        Cells(i, Day(bsl) + 3).Resize(1, bts) = ""
                    End If
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    St.Range("D2:D" & Rows.Count).ClearContents
    For i = 2 To St.Cells(Rows.Count, "A").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "F")
                If Not d.exists(deg) Then
                    d.Add deg, Nothing
                    St.Cells(i, "D") = St.Cells(i, "D") & "," & deg
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
        St.Cells(i, "D") = Right(St.Cells(i, "D"), Len(St.Cells(i, "D")) - 1)
        Set d = Nothing
    Next i
 
End Sub

 

[aligunes]

Sn. aligunes Merhaba

Aylık Tazminat ifadenizden şunumu anlamalıyız. Kişi veya kişilerin Aylık çalışma puantajı olarak mı düşünmeliyiz yoksa farklı bir çalışmamı, Aylık Tazminat Terimini çalışma hayatında sizin ilk defa ifade etmenizden ne anlamalıyız ki ona göre mantık yürütelim ve size örnek dosya veya dosyalar gönderebilelim. Zira Tazminat ifadesi çalışma hayatında belli bir süre çalışılması sonucunda koşullara uygun olması halinde yapılan toplu ödemedir.

Tazminat maaş haricinde yapılan bir ek ödemedir. Her ayın 1..30 arası personelin izin-rapor..vs düşülerek kalan gün sayısı kadar yapılır puantajda personelin izinli ve raporlu olduğu günler tazminat alamaz fiilen çalıştığı gün alır. Bu nedenle sayfa sekmesinde personelin izin rapor takiplerinin yapıldığı sayfadan verilerin baz alınarak aylık puantaj hazırlayarak hem izin icmal takibi hem de tazminat hazırlamak istiyorum.

 

[Ömer]

Kodları denediniz mi?

 

[aligunes]

Kodları denediniz mi?

kodları denedim çalışıyor elinize sağlık sadece liste sayfasında aşağıdaki şekilde yazması gerekiyor bir kişiye ait aynı izin türlerini toplayarak aşağıdaki şekilde yazması gerekiyor

(14) Gün İdari İzin (Tecrit)

(5) Gün Senelik izin, (1) Gün Evlilik Yıl Dönümü İzni

 

[Ömer]

Deneyiniz.

Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String, j As Integer
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, d As Object, a1, a2, s
 
    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Lİste")
 
    Application.ScreenUpdating = False
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "B").End(xlUp).Row
    Range("D4:AH" & son).ClearContents
 
    trh = DateSerial(Year("1." & [AI2]), Month("1." & [AI2]) + 1, 0)
    gun = Day(trh)
 
    For i = 4 To son
        Cells(i, "D").Resize(1, gun) = "x"
        Set c = Si.[A:A].Find(Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                bsl = Si.Cells(c.Row, "C")
                bts = Si.Cells(c.Row, "E")
                If bts > 0 Then
                    If Si.Cells(c.Row, "D") > trh Then bts = trh - bsl - 1
                    If Format(bsl, "MMMM") = WorksheetFunction.Proper(UCase(Replace(Replace([AI2], _
                        "ı", "I"), "i", "İ"))) Then
                        Cells(i, Day(bsl) + 3).Resize(1, bts) = ""
                    End If
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    St.Range("D2:D" & Rows.Count).ClearContents
    For i = 2 To St.Cells(Rows.Count, "A").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "F")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "E")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "E")
                    d.Item(deg) = s
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
        a1 = d.keys: a2 = d.items
        For j = 0 To d.Count - 1
            St.Cells(i, "D") = St.Cells(i, "D") & ", " & "(" & a2(j) & ")" & a1(j)
        Next j
        St.Cells(i, "D") = Right(St.Cells(i, "D"), Len(St.Cells(i, "D")) - 2)
        Set d = Nothing
    Next i
    
End Sub

 

[aspava]

Ömer Hocam ; konudan alakasız olarak bir soru da ben sormak istiyorum. İzin İcmal sayfasında "senelik izin " giden bir personel 'i puantaj sayfasında boş değil de "Yİ" izin gibi yazdırabiliriz. Mazeret izni ise " Mİ" gibi .. sizin kodlarınızı kendi puantaj tabloma göre uyarlamak istiyorum.

 

[Ömer]

Merhaba,

Evet olabilir. Yalnız şartlar sadece iki şart değil sanırım. Fazlaysa; bunun için bence şartlar ve karşılıklarını hücreye yazıp oradan almak daha doğru olacaktır. Örneğin K:L sütun aralığına. Değilse tüm şartları söylerseniz ona göre hazırlayayım.

 

[aspava]

o zaman ben gece gece sizi yormayayım hocam, örnek bir dosya hazırlayayım müsait olduğunuz da ilgilenirseniz sevinirim.

 

[Ömer]

Eki inceleyiniz. "İzin İcmal" sayfası K sütununa izin adlarını L sütununa kodlarını kendimce yazdım. Siz kendinize göre uyarlarsınız.

Not: #16 numaralı mesaj doğrultusunda dosya güncellendi.

 

[aligunes]

Eki inceleyiniz. "İzin İcmal" sayfası K sütununa izin adlarını L sütununa kodlarını kendimce yazdım. Siz kendinize göre uyarlarsınız.

Ömer hocam izin icmalde bir kişi ör: 25/07/2020 de 14 gün izne ayrıldı dönüş tarihi 08/08/2020 o zaman makro hata veriyor

Burada Puantaj AI1 ve AI2 deki tarih baz alınarak sadece ilgili aya denk gelen günleri düşse sorun çözülecek AI2:AI2 ye AĞUSTOS 2020 girdiğimde de Ağustos ayına denk gelen günleri düşer tazminat ay baz alınarak hazırlanıyor personel ayın değişik tarihlerinde izinli raporlu olduğundan bir sonraki aya da sarkabiliyor önemli olan ay baz alınarak puantaj hazırlamak listeye de açıklama kısmına aya denk gelen düşüm yaptığı gün sayısını yazar

 

[aligunes]

Ömer hocam ya da MAKRO yazabilen diğer hocalarım 13 nolu mesajda belirtmiş olduğum hatayı düzeltebilir misiniz ?

 

[Ömer]

Deneyiniz.
"İzin İcmal" sayfası E sütununa =D2-C2+1 formülünü yazmanız daha doğru olacaktır.

Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String, j As Integer
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, d As Object, a1, a2, s, ay As String
 
    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Lİste")
 
    Application.ScreenUpdating = False
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "B").End(xlUp).Row
    Range("D4:AH" & son).ClearContents
 
    trh = DateSerial(Year("1." & [AI2]), Month("1." & [AI2]) + 1, 0)
    gun = Day(trh)
 
    For i = 4 To son
        Cells(i, "D").Resize(1, gun) = "x"
        Set c = Si.[A:A].Find(Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                bsl = Si.Cells(c.Row, "C")
                bts = Si.Cells(c.Row, "D")
                ay = WorksheetFunction.Proper(UCase(Replace(Replace([AI2], "ı", "I"), "i", "İ")))
                
                If Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") <> ay Then Exit Do
                
                If Si.Cells(c.Row, "E") > 0 Then
                    
                    If Format(bsl, "MMMM") = ay And Format(bts, "MMMM") = ay Then
                        bsl = Day(bsl)
                        bts = Si.Cells(c.Row, "E")
                    ElseIf Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") = ay Then
                        bsl = 1
                        bts = Day(bts)
                    Else
                        bts = trh - bsl + 1
                        bsl = Day(bsl)
                    End If
                                        
                    Cells(i, bsl + 3).Resize(1, bts) = ""
                    
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    St.Range("D2:D" & Rows.Count).ClearContents
    For i = 2 To St.Cells(Rows.Count, "A").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "F")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "E")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "E")
                    d.Item(deg) = s
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
        a1 = d.keys: a2 = d.items
        For j = 0 To d.Count - 1
            St.Cells(i, "D") = St.Cells(i, "D") & ", " & "(" & a2(j) & ")" & a1(j)
        Next j
        St.Cells(i, "D") = Right(St.Cells(i, "D"), Len(St.Cells(i, "D")) - 2)
        Set d = Nothing
    Next i
    
End Sub

 

[aspava]

Ömer Hocam Merhaba ;
İyi Akşamlar ,

Arkadaşın puantajı kendime uyarlamaya çalıştım ama başarılı olamadım. Benim bir de ilave olarak yapmak istediğim Pazar günleri çalışan personelleri yazdığım " Pazar icmal" dosyası dışında kalan personellerin pazar günleri puantajına x değil de " HT" ibaresi koyması.

 

[aligunes]

Ömer hocam elinize sağlık puantaj makro çalışıyor yani seçtiğim ayın iznini düşüyor şimdi de puantajda boş olan yerlere izinlerin kodlamasını yazıyordu daha öce şimdi yazmıyor ayrıca listede açıklama kısmına toplam izni yazıyor mesela 25 temmuzda başlayan 4 Ağustosta biten izin için puantajı doğru işaretliyor liste açıklama kısmına ilgili aya ait olan toplamı değil genel toplamı yazıyor dediğim gibi bir de izin kodlamalarını yazmıyor birde puantajda isimle sicil arasına unvan ekleyeceğim kod bozulur mu? ayrıca puantajda izinli olunan yerleri hücreyi gri renk yapabilir miyiz.

 

[Ömer]

puantajda isimle sicil arasına unvan ekleyeceğim kod bozulur mu? ayrıca puantajda izinli olunan yerleri hücreyi gri renk yapabilir miyiz.

Sayın @aligunes
Son 2 yazdığınızdan başlayayım. Diğer yazdıklarınızı anlamadım.

1) Eğer eski sütunların yeri değişirse evet bozulur.,
2) Yapılabilir, yalnız diğer konular netleşince ilavesini yaparız.

 

[Ömer]

Ömer Hocam Merhaba ;
İyi Akşamlar ,

Arkadaşın puantajı kendime uyarlamaya çalıştım ama başarılı olamadım. Benim bir de ilave olarak yapmak istediğim Pazar günleri çalışan personelleri yazdığım " Pazar icmal" dosyası dışında kalan personellerin pazar günleri puantajına x değil de " HT" ibaresi koyması.

Sayın @aspava
Deneyiniz.

Sub puantaj_aspava()

    Dim Si As Worksheet, Sp As Worksheet, trh As Date, gun As Byte, deg As String, j As Byte, Adr1 As String
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, d As Range, k As Byte, ay As String

    Set Si = Sheets("İzin İcmal")
    Set Sp = Sheets("Pazar icmal")

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With

    Sheets("puantaj").Select
    Range("G5:AK104").ClearContents
   
    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AD2], "ı", "I"), "i", "İ")))
    trh = DateSerial([AI2], Month("1." & [AD2] & "." & [AI2]) + 1, 0)
    gun = Day(trh)

    For i = 5 To 104
   
        Cells(i, "G").Resize(1, gun) = "X"
       
        For j = 7 To 37
            If Cells(3, j) = "Pazar" Then
                Cells(i, j) = "HT"
            End If
        Next j
       
        If Format(Cells(i, "F"), "MMMM") = ay And Cells(i, "F") <> "" Then
            Cells(i, "G").Resize(1, Day(Cells(i, "F"))) = ""
        End If
       
        If Format(Cells(i, "AL"), "MMMM") = ay And Cells(i, "AL") <> "" Then
            Cells(i, 7 + Day(Cells(i, "AL"))).Resize(1, trh - Cells(i, "AL")) = ""
        End If
       
        Set c = Si.[A:A].Find(Cells(i, "B"), , xlFormulas, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                bsl = Si.Cells(c.Row, "C")
                bts = Si.Cells(c.Row, "D")
               
                If Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") <> ay Then Exit Do
               
                If Si.Cells(c.Row, "E") > 0 Then
                   
                    If Format(bsl, "MMMM") = ay And Format(bts, "MMMM") = ay Then
                        bsl = Day(bsl)
                        bts = Si.Cells(c.Row, "E")
                    ElseIf Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") = ay Then
                        bsl = 1
                        bts = Day(bts)
                    Else
                        bts = trh - bsl + 1
                        bsl = Day(bsl)
                    End If
                       
                    If WorksheetFunction.CountIf(Si.[K:K], Si.Cells(c.Row, "F")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "F"), Si.[K:K], 0)
                        Cells(i, bsl + 6).Resize(1, bts) = Si.Cells(k, "L")
                    Else
                        Cells(i, bsl + 6).Resize(1, bts) = ""
                    End If
                       
                End If
                Set c = Si.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
       
        Set d = Sp.[A:A].Find(Cells(i, "B"), , xlFormulas, xlWhole)
        If Not d Is Nothing Then
            Adr1 = d.Address
            Do
                If Format(Sp.Cells(d.Row, "C"), "MMMM") = ay Then
                    Cells(i, Day(Sp.Cells(d.Row, "C")) + 6) = "X"
                End If
                Set d = Sp.[A:A].FindNext(d)
            Loop While Not d Is Nothing And d.Address <> Adr1
        End If
       
    Next i

    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   
End Sub