Tazminat Puantaj Çalışması

[Ömer]

Kodları güncelledim tekrar deneyiniz.

 

[aspava]

Kodları güncelledim tekrar deneyiniz.

Hocam , kontrol ediyorum hepsi harika bir şekilde çalışıyor sadece 2 hususta sorun var gibi gözüküyor bir tanesi Resmi tatilleri yani (RT) yazmıyor. Diğeri de izin tarihleri hafta sonu yada resmi tatillerde denk gelen kişilere izin yazmamasi bunu daha önce halletmistiniz.

 

[Ömer]

Hocam , kontrol ediyorum hepsi harika bir şekilde çalışıyor sadece 2 hususta sorun var gibi gözüküyor bir tanesi Resmi tatilleri yani (RT) yazmıyor. Diğeri de izin tarihleri hafta sonu yada resmi tatillerde denk gelen kişilere izin yazmamasi bunu daha önce halletmistiniz.

#57 numaralı mesajı güncelledim, deneyiniz.

 

[aspava]

#57 numaralı mesajı güncelledim, deneyiniz.

Ömer Hocam , Teşekkür ederim ellerinize sağlık. şuanda sorun gözükmüyor , Kontrollere devam ediyorum.

 

[aligunes]

Yukarıdaki linkte yazılan makroda liste sekmesinde listeleme 2.satırdan başlıyordu üste bir satır eklemem gerekiyor listeleme 3.satırdan başlaması lazım kodlarda değişiklik için yardımcı olur musunuz. Yada değiştirmem gereken yeri belirtirseniz

@Ömer hocam yazılan makroda puantaj sayfasında en son 203 satıra kadar işlem yapıyor, Liste sayfasında da 203 satıra işlem yapsa puantajla aynı olsa listenin altına açtığım isim imza bozulmazdı daha iyi olurdu yardımcı olursanız sevinirim.

 

[aligunes]

Sayın @aligunes
Deneyiniz.

Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, ilk_t As Date, son_t As Date, gun As Byte
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, k As Integer, j As Date, izn As String
    Dim d As Object, a1, a2, s, deg As String, sure As Double, ay As String, topla As Double

    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Liste")

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

    sure = Timer

    Sheets("Puantaj").Select
    Range("E4:AI203").ClearContents

    son = Cells(Rows.Count, "A").End(xlUp).Row - 1
    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AJ2], "ı", "I"), "i", "İ")))
    ilk_t = CDate("1." & ay & "." & [AJ1])
    son_t = DateSerial([AJ1], Month("1." & ay & "." & [AJ1]) + 1, 0)
    gun = Day(son_t)

    St.Range("A3:G" & Rows.Count).ClearContents
    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Application.CutCopyMode = False
    St.Range("F3").Resize(son - 3, 1) = "3.BÖLGE"

    For i = 4 To 203

        If Cells(i, "B") <> "" Then
            Set d = CreateObject("Scripting.Dictionary")
            Cells(i, "E").Resize(1, gun) = "X"
        
            For j = ilk_t To son_t
                If Application.Weekday(j, 2) = 7 Then
                    Cells(i, Day(j) + 4) = ""
                End If
            Next j
        
            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, "D")
                    bts = Si.Cells(c.Row, "E")
                  
                    If bts < ilk_t And bsl < ilk_t Then
                    Else
                    izn = ""
                    If WorksheetFunction.CountIf(Si.[L:L], Si.Cells(c.Row, "G")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "G"), Si.[L:L], 0)
                        izn = Si.Cells(k, "M")
                    End If
                
                    topla = 0
                    If Si.Cells(c.Row, "F") > 0 Then
                        For j = ilk_t To son_t
                            If j >= bsl And j <= bts Then
                                Cells(i, Day(j) + 4) = izn
                                topla = topla + 1
                            End If
                        Next j
                    End If
                  
                    deg = Si.Cells(c.Row, "G")
                    If Not d.exists(deg) Then
                        s = topla
                        d.Add deg, s
                    Else
                        s = d.Item(deg)
                        s = s + topla
                        d.Item(deg) = s
                    End If
                
                    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 k = 0 To d.Count - 1
                St.Cells(i - 1, "G") = St.Cells(i - 1, "G") & ", " & "(" & a2(k) & ")" & a1(k)
            Next k
        
            If St.Cells(i - 1, "G") <> "" Then
                St.Cells(i - 1, "G") = Right(St.Cells(i - 1, "G"), Len(St.Cells(i - 1, "G")) - 2)
            End If
        
            Set d = Nothing
            'topla = 0
          
        End If
    Next i

    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .CutCopyMode = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    MsgBox "İşlem Süresi --- " & Format(Timer - sure, "0.00")

End Sub

@Ömer hocam mrb yazılan makroda puantaj sayfasında en son 203 satıra kadar işlem yapıyor, Liste sayfasında da 203 satıra işlem yapsa puantajla aynı olsa listenin altına açtığım isim imza bozulmazdı daha iyi olurdu yardımcı olursanız sevinirim. Teşekkür ederim.

 

[Ömer]

@aligunes konu üzerinden zaman geçtiği için içeriğini hatırlayamadım. Örnek dosya ekleyip istediğinizi dosya içinde detaylı açıklar mısınız.

 

[aligunes]

@Ömer hocam mrb dosyayı ekledim yazılan makroda puantaj sayfasında en son 203 satıra kadar işlem yapıyor, Liste sayfasında da 203 satıra işlem yapsa puantajla aynı olsa listenin altına açtığım isim imza bozulmazdı daha iyi olurdu yardımcı olursanız sevinirim. Teşekkür ederim.

 

[Ömer]

Değiştirmeye çalıştım, detaylı deneyip eksik yada hata varsa bilgi verirsiniz.

Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, ilk_t As Date, son_t As Date, gun As Byte
    Dim i As Long, c As Range, Adr As String, bsl As Date, bts As Double, k As Integer, j As Date, izn As String
    Dim d As Object, a1, a2, s, deg As String, sure As Double, ay As String, topla As Double
  
    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Liste")

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
  
    sure = Timer
  
    Sheets("Puantaj").Select
    Range("E4:AI203").ClearContents
  
    son = 203 'Cells(Rows.Count, "A").End(xlUp).Row - 1
    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AJ2], "ı", "I"), "i", "İ")))
    ilk_t = CDate("1." & ay & "." & [AJ1])
    son_t = DateSerial([AJ1], Month("1." & ay & "." & [AJ1]) + 1, 0)
    gun = Day(son_t)
  
    St.Range("A3:G202").ClearContents
    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Application.CutCopyMode = False
    St.Range("F3").Resize(son - 3, 1) = "3.BÖLGE"

    For i = 4 To 203
  
        If Cells(i, "B") <> "" Then
            Set d = CreateObject("Scripting.Dictionary")
            Cells(i, "E").Resize(1, gun) = "X"
          
            For j = ilk_t To son_t
                If Application.Weekday(j, 2) = 7 Then
                    Cells(i, Day(j) + 4) = ""
                End If
            Next j
          
            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, "D")
                    bts = Si.Cells(c.Row, "E")
                    
                    If bts < ilk_t And bsl < ilk_t Then
                    Else
                    izn = ""
                    If WorksheetFunction.CountIf(Si.[L:L], Si.Cells(c.Row, "G")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "G"), Si.[L:L], 0)
                        izn = Si.Cells(k, "M")
                    End If
                  
                    topla = 0
                    If Si.Cells(c.Row, "F") > 0 Then
                        For j = ilk_t To son_t
                            If j >= bsl And j <= bts Then
                                Cells(i, Day(j) + 4) = izn
                                topla = topla + 1
                            End If
                        Next j
                    End If
                    
                    deg = Si.Cells(c.Row, "G")
                    If Not d.exists(deg) Then
                        s = topla
                        d.Add deg, s
                    Else
                        s = d.Item(deg)
                        s = s + topla
                        d.Item(deg) = s
                    End If
                  
                    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 k = 0 To d.Count - 1
                St.Cells(i - 1, "G") = St.Cells(i - 1, "G") & ", " & "(" & a2(k) & ")" & a1(k)
            Next k
          
            If St.Cells(i - 1, "G") <> "" Then
                St.Cells(i - 1, "G") = Right(St.Cells(i - 1, "G"), Len(St.Cells(i - 1, "G")) - 2)
            End If
          
            Set d = Nothing
            'topla = 0
            
        End If
    Next i

    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .CutCopyMode = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
  
    MsgBox "İşlem Süresi --- " & Format(Timer - sure, "0.00")

End Sub