Tazminat Puantaj Çalışması

A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Ömer Hocam , Çok teşekkür ederim. Şuanda sorun gözükmüyor. Elinize sağlık.
 
A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Ömer Hocam , Sizi çok yordum hakkınızı helal edin. Sizden son bir istekte bulunmak istiyorum. Zamanız olursa ilgilenirseniz sevinirim. Ekte örnekte belirtiğim gibi " F" Sütununda yer alan Bu ay işe girmiş ise tarihi kısmında yer alan tarihin de yer alan tarihe göre puantajı doldurması ve " AL" sütununda yer alan Bu ay işten çıkmışsa tarihi kısmında yer alan tarihte bitirmesi mümkün müdür. Eğer sizi uğraştıracak ise manuel doldurabilirim.
 

Ekli dosyalar

Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Dosyanızı incelemedim fakat kodları yazarken buna dikkat etmiştim. Problem mi oldu.
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Blokların sırası hatalı olmuş.
Deneyiniz.
Kod: 
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
        
        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
      
        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
      
    Next i

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

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
denedim hocam mükemmel bir şekilde çalışıyor. kontrolleri bitirdikten sonra siteye eklerim faydalanmak isteyen arkadaşlara yardımcı olur teşekkür ederim.
 
aligunes

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
Ömer' Alıntı:
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.
Genişletmek için tıkla ...
@Ömer hocam şablonda yaptığım düzenleme ve AÇIKLAMA sekmesinde gerekli açıklamaları yazdım. bu tablo ve şablon ile açıklamalar ışığında yapabilir miyiz kusura bakmayın sizi de yordum hakkınızı helal edin
 

Ekli dosyalar

A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Ömer' Alıntı:
Blokların sırası hatalı olmuş.
Deneyiniz.
Kod: 
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
      
        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
    
        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
    
    Next i

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

End Sub
Genişletmek için tıkla ...
Ömer Hocam , Bir şey fark ettim işe girişleri 1 gün sonrasında puantajda gösteriyor. Çıkışlarda sorun gözükmüyor.
 
Son düzenleme:
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
aligunes' Alıntı:
@Ömer hocam şablonda yaptığım düzenleme ve AÇIKLAMA sekmesinde gerekli açıklamaları yazdım. bu tablo ve şablon ile açıklamalar ışığında yapabilir miyiz kusura bakmayın sizi de yordum hakkınızı helal edin
Genişletmek için tıkla ...
Sayın @aligunes
Deneyiniz.
Kod: 
Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String, j As Integer, k As Byte
    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, t As Date
 
    Set Si = Sheets("İzin İcmal")
    Set St = Sheets("Liste")
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
    
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "A").End(xlUp).Row - 1
    Range("E4:AI" & son).ClearContents
 
    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AJ2], "ı", "I"), "i", "İ")))
    trh = DateSerial([AJ1], Month("1." & [AJ2] & "." & [AJ1]) + 1, 0)
    gun = Day(trh)
 
    For i = 4 To son
    
        Cells(i, "E").Resize(1, gun) = "X"
      
        For j = 5 To 35
            t = Cells(3, j) & "." & [AJ2] & "." & [AJ1]
            If Application.Weekday(CDate(t), 2) = 7 Then
                Cells(i, j) = ""
            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 Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") <> ay Then Exit Do
              
                If Si.Cells(c.Row, "F") > 0 Then
                  
                    If Format(bsl, "MMMM") = ay And Format(bts, "MMMM") = ay Then
                        bsl = Day(bsl)
                        bts = Si.Cells(c.Row, "F")
                    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.[L:L], Si.Cells(c.Row, "G")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "G"), Si.[L:L], 0)
                        Cells(i, bsl + 4).Resize(1, bts) = Si.Cells(k, "M")
                    Else
                        Cells(i, bsl + 4).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("A2:G" & Rows.Count).ClearContents

    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
  
    St.Range("F2").Resize(son - 3, 1) = "3.BÖLGE"
    
    For i = 2 To St.Cells(Rows.Count, "B").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "G")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "F")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "F")
                    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, "G") = St.Cells(i, "G") & ", " & "(" & a2(j) & ")" & a1(j)
        Next j
        If St.Cells(i, "G") <> "" Then
            St.Cells(i, "G") = Right(St.Cells(i, "G"), Len(St.Cells(i, "G")) - 2)
        End If
        Set d = Nothing
    Next i
    
    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .ScreenUpdating = True
        .CutCopyMode = False
        .EnableEvents = True
    End With
    
End Sub
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
aspava' Alıntı:
Ömer Hocam , Bir şey fark ettim işe girişleri 1 gün sonrasında puantajda gösteriyor. Çıkışlarda sorun gözükmüyor.
Genişletmek için tıkla ...
Sayın @aspava
Detaylı deneme yapmadığım için bu tür aksaklıkları çıkabilir.
Deneyiniz.
Kod: 
Sub puantaj_aspava()

    Dim Si As Worksheet, Sp As Worksheet, son As Long, ilk_t As Date, son_t As Date, gun As Byte, d As Range
    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, 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
 
    son = Cells(Rows.Count, "B").End(xlUp).Row
    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AD2], "ı", "I"), "i", "İ")))
    ilk_t = CDate("1." & ay & "." & [AI2])
    son_t = DateSerial([AI2], Month("1." & ay & "." & [AI2]) + 1, 0)
    gun = Day(son_t)

    For i = 5 To son
 
        If Cells(i, "B") <> "" Then
     
            Cells(i, "G").Resize(1, gun) = "X"
         
            For k = 7 To 37
                If Cells(3, k) = "Pazar" Then
                    Cells(i, k) = "HT"
                End If
            Next k
         
            Set d = Sp.[A:A].Find(Cells(i, "B"), , xlFormulas, xlWhole)
            If Not d Is Nothing Then
                Adr = d.Address
                Do
                    If Sp.Cells(d.Row, "C") >= ilk_t And Sp.Cells(d.Row, "C") <= son_t 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 <> Adr
            End If
         
            If Cells(i, "F") >= ilk_t And Cells(i, "F") <= son_t And Cells(i, "F") <> "" And Day(Cells(i, "F")) <> 1 Then
                Cells(i, "G").Resize(1, Day(Cells(i, "F")) - 1) = ""
            End If
   
            If Cells(i, "AL") >= ilk_t And Cells(i, "AL") <= son_t And Cells(i, "AL") <> "" Then
                Cells(i, 7 + Day(Cells(i, "AL"))).Resize(1, son_t - 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 bts < ilk_t And bsl < ilk_t Then
                    Else
                    izn = ""
                    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)
                        izn = Si.Cells(k, "L")
                    End If
               
                    If Si.Cells(c.Row, "E") > 0 Then
                        For j = ilk_t To son_t
                            If j >= bsl And j <= bts Then
                                Cells(i, Day(j) + 6) = izn
                            End If
                        Next j
                    End If
                    End If
                 
                   Set c = Si.[A:A].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
           
        End If
    Next i
   
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
 
End Sub
 
Son düzenleme:
A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Ömer' Alıntı:
Sayın @aspava
Detaylı deneme yapmadığım için bu tür aksaklıkları çıkabilir.
Deneyiniz.
Kod: 
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
       
        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
     
        If Format(Cells(i, "F"), "MMMM") = ay And Cells(i, "F") <> "" And Day(Cells(i, "F")) <> 1 Then
            Cells(i, "G").Resize(1, Day(Cells(i, "F")) - 1) = ""
        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
     
    Next i

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

End Sub
Genişletmek için tıkla ...
Ömer Hocam , Teşekkür ederim. Ben denemelere devam ediyorum. Bir aksaklık gözüme çarparsa geri dönüş yaparım. Hocam emeğinize sağlık.
 
aligunes

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
Ömer' Alıntı:
Sayın @aligunes
Deneyiniz.
Kod: 
Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String, j As Integer, k As Byte
    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, t As Date

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

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
  
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "A").End(xlUp).Row - 1
    Range("E4:AI" & son).ClearContents

    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AJ2], "ı", "I"), "i", "İ")))
    trh = DateSerial([AJ1], Month("1." & [AJ2] & "." & [AJ1]) + 1, 0)
    gun = Day(trh)

    For i = 4 To son
  
        Cells(i, "E").Resize(1, gun) = "X"
    
        For j = 5 To 35
            t = Cells(3, j) & "." & [AJ2] & "." & [AJ1]
            If Application.Weekday(CDate(t), 2) = 7 Then
                Cells(i, j) = ""
            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 Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") <> ay Then Exit Do
            
                If Si.Cells(c.Row, "F") > 0 Then
                
                    If Format(bsl, "MMMM") = ay And Format(bts, "MMMM") = ay Then
                        bsl = Day(bsl)
                        bts = Si.Cells(c.Row, "F")
                    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.[L:L], Si.Cells(c.Row, "G")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "G"), Si.[L:L], 0)
                        Cells(i, bsl + 4).Resize(1, bts) = Si.Cells(k, "M")
                    Else
                        Cells(i, bsl + 4).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("A2:G" & Rows.Count).ClearContents

    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    St.Range("F2").Resize(son - 3, 1) = "3.BÖLGE"
  
    For i = 2 To St.Cells(Rows.Count, "B").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "G")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "F")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "F")
                    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, "G") = St.Cells(i, "G") & ", " & "(" & a2(j) & ")" & a1(j)
        Next j
        If St.Cells(i, "G") <> "" Then
            St.Cells(i, "G") = Right(St.Cells(i, "G"), Len(St.Cells(i, "G")) - 2)
        End If
        Set d = Nothing
    Next i
  
    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .ScreenUpdating = True
        .CutCopyMode = False
        .EnableEvents = True
    End With
  
End Sub
Genişletmek için tıkla ...
Ömer' Alıntı:
Sayın @aligunes
Deneyiniz.
Kod: 
Sub puantaj()

    Dim Si As Worksheet, St As Worksheet, son As Long, trh As Date, gun As Byte, deg As String, j As Integer, k As Byte
    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, t As Date

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

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
   
    Sheets("Puantaj").Select

    son = Cells(Rows.Count, "A").End(xlUp).Row - 1
    Range("E4:AI" & son).ClearContents

    ay = WorksheetFunction.Proper(UCase(Replace(Replace([AJ2], "ı", "I"), "i", "İ")))
    trh = DateSerial([AJ1], Month("1." & [AJ2] & "." & [AJ1]) + 1, 0)
    gun = Day(trh)

    For i = 4 To son
   
        Cells(i, "E").Resize(1, gun) = "X"
     
        For j = 5 To 35
            t = Cells(3, j) & "." & [AJ2] & "." & [AJ1]
            If Application.Weekday(CDate(t), 2) = 7 Then
                Cells(i, j) = ""
            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 Format(bsl, "MMMM") <> ay And Format(bts, "MMMM") <> ay Then Exit Do
             
                If Si.Cells(c.Row, "F") > 0 Then
                 
                    If Format(bsl, "MMMM") = ay And Format(bts, "MMMM") = ay Then
                        bsl = Day(bsl)
                        bts = Si.Cells(c.Row, "F")
                    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.[L:L], Si.Cells(c.Row, "G")) > 0 Then
                        k = WorksheetFunction.Match(Si.Cells(c.Row, "G"), Si.[L:L], 0)
                        Cells(i, bsl + 4).Resize(1, bts) = Si.Cells(k, "M")
                    Else
                        Cells(i, bsl + 4).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("A2:G" & Rows.Count).ClearContents

    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
 
    St.Range("F2").Resize(son - 3, 1) = "3.BÖLGE"
   
    For i = 2 To St.Cells(Rows.Count, "B").End(xlUp).Row
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "G")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "F")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "F")
                    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, "G") = St.Cells(i, "G") & ", " & "(" & a2(j) & ")" & a1(j)
        Next j
        If St.Cells(i, "G") <> "" Then
            St.Cells(i, "G") = Right(St.Cells(i, "G"), Len(St.Cells(i, "G")) - 2)
        End If
        Set d = Nothing
    Next i
   
    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .ScreenUpdating = True
        .CutCopyMode = False
        .EnableEvents = True
    End With
   
End Sub
Genişletmek için tıkla ...
@Ömer hocam 26 nolu mesaj ekinde paylaştığım excel dosyasına kodları uyguladım. izin icmalin 146.sırasındaki 402926 sicilin

18.06.2020

15.09.2020

90

Refakat İzni


puantaj sayfasına işlemiyor normalde puantaj sayfasında 21. nolu sırada 402926 sicilin ayın tamamını Rİ refakat izni işaretlemesi gerekiyor 0 tazminat alması gerekiyor
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Sayın @aligunes
Deneyiniz. Pazar günleri hariç boş gelen olursa, L:M sütununda tanımı yapılmamıştır.
Kod: 
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
    
    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)
 
    For i = 4 To 203
    
        If Cells(i, "B") <> "" Then
        
            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
                    
                      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
                              End If
                          Next j
                      End If
                      End If
                      
                     Set c = Si.[A:A].FindNext(c)
                  Loop While Not c Is Nothing And c.Address <> Adr
              End If
              
        End If
    Next i

    St.Range("A2:G" & Rows.Count).ClearContents

    Range("A4").Resize(son - 3, 4).Copy
    St.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    
    St.Range("F2").Resize(son - 3, 1) = "3.BÖLGE"
    
    For i = 2 To St.Cells(Rows.Count, "B").End(xlUp).Row
    
        Set d = CreateObject("Scripting.Dictionary")
        Set c = Si.[A:A].Find(St.Cells(i, "B"), , xlValues, xlWhole)
        
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg = Si.Cells(c.Row, "G")
                If Not d.exists(deg) Then
                    s = Si.Cells(c.Row, "F")
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                    s = s + Si.Cells(c.Row, "F")
                    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 k = 0 To d.Count - 1
            St.Cells(i, "G") = St.Cells(i, "G") & ", " & "(" & a2(k) & ")" & a1(k)
        Next k
        
        If St.Cells(i, "G") <> "" Then
            St.Cells(i, "G") = Right(St.Cells(i, "G"), Len(St.Cells(i, "G")) - 2)
        End If
        
        Set d = Nothing
        
    Next i
    
    With Application
        .Calculation = xlAutomatic
        Range("AJ4").Resize(son - 3, 1).Copy
        St.Range("E2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        .ScreenUpdating = True
        .CutCopyMode = False
        .EnableEvents = True
    End With
    
    MsgBox "İşlem Süresi --- " & Format(Timer - sure, "0.00")

End Sub
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Sayın @aspava

#29 nolu mesajdaki kodları güncelledim. Eski kodlarda tarihle ilgili problem vardı. Yeni kodları deneyiniz.
 
aligunes

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
@Ömer hocam temmuz ve ağustos seçtiğimde kod çalışıyor haziran seçtiğimde aşağıdaki hatayı veriyor kodları örnek dosya üzerinde deneyip atabilir misiniz bir de 15-20 sn sürüyor yazma işlemi kasıyor bu normal mi en son mesela 25 temmuz 2020 de 10 gün izne ayılma durumunda temmuzu hesaplatınca liste açıklama kısmına (7) gün senelik izin yazması lazım 10 gün yazıyor. ağustosta da (3) gün senelik izin yazası lazım.
220003
 
A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Ömer Hocam , Kontrol ettim diğerinde kullandığı izin süresinde "X" koyuyordu şimdi tarih aralığında koyuyor daha sağlıklı oldu. Sizi uğraştırmayacak ise eğer izin tarihi aralığında Pazar gününe Yada Resmi Tatile gelen güne izinli yazmasak olur mu ?
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Ay hatası için #32 numaralı mesajı güncelledim, tekrar deneyiniz. (Küçük büyük harf dil probleminden dolayı)

Hızla ilgili bende bir sorun olmadı. Bende 1 sn. altında hesapladı. Diğer sorunuzu tam anlayamadım, sicil numarası vererek daha detaylı açıklar mısınız.

220004
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
aspava' Alıntı:
Ömer Hocam , Kontrol ettim diğerinde kullandığı izin süresinde "X" koyuyordu şimdi tarih aralığında koyuyor daha sağlıklı oldu. Sizi uğraştırmayacak ise eğer izin tarihi aralığında Pazar gününe Yada Resmi Tatile gelen güne izinli yazmasak olur mu ?
Genişletmek için tıkla ...
Boş mu bırakması gerekiyor. Ayrıca resmi tatilleri yazdığınız bir bölüm olmalı. Buna uygun dosya eklerseniz dosya üzerinden bakalım.
 
A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
218
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
26-01-2027
Resmi tatillerin olduğu bir dosyayı ekledim. örnek bir dosya da yapmak istediğimi belirtim hocam.
 

Ekli dosyalar

aligunes

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
Ömer' Alıntı:
Ay hatası için #32 numaralı mesajı güncelledim, tekrar deneyiniz. (Küçük büyük harf dil probleminden dolayı)

Hızla ilgili bende bir sorun olmadı. Bende 1 sn. altında hesapladı. Diğer sorunuzu tam anlayamadım, sicil numarası vererek daha detaylı açıklar mısınız.

Ekli dosyayı görüntüle 220004
Genişletmek için tıkla ...
@Ömer hocam örneklerle anlatmaya çalıştım.220008
 
aligunes

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
220009

bende süre çok uzun ömer hocam siz kodların eklendiği bir dosya ekleyin bir de onu deneyeyim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst