Belirti Kurala Bağlı Mesai Dağılımı

1 2 3 4 5 6

Hâlâ araştırıyorum özellikle dağıtma kısmi uğraştırıyor, kafamda şablonu olusturmaya calisiyorum.

Zaman ayırıp ilgilendiğiniz için teşekkür ederim.

Aşağıdaki kod işinize yarayabilir, denemelerimde sorun çıkarmadı
0-31 aradı denedim, çalıştığı günden fazla mesai eklenirse uyarı veriyor
Dilerim işinize yarar
Not: sonucları kontrol etmek icin imza alanını geçici olarak değiştirdim.
Imza alanını eski haline getirebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim xStun As Range

Dim xSay, xSatir As Long

Dim xOran, xMesai, y As Integer

Dim sBolge As String

Dim xDizi() As String



Set xStun = Range("AK:AK")



If Not Application.Intersect(xStun, Range(Target.Address)) Is Nothing Then



    

    sBolge = ""

    xMesai = Target.Value

    xSatir = Target.Row + 1

    xSay = Application.WorksheetFunction.CountIf(Range("D" & xSatir & ":Ah" & xSatir), "X")

    If xSay < xMesai Then

        MsgBox ("mesai saati ( " & xMesai & " saat) çalıştığı günden ( " & xSay & " gün ) fazla. Mesai saatini düzeltin")

        Exit Sub

    End If

    Range("D" & xSatir - 1 & ":Ah" & xSatir - 1).ClearContents



    For x = 4 To 34

        If Cells(xSatir, x).Value = "X" Then sBolge = sBolge & "," & x

    Next x



    Do While xMesai > 0

      

        sBolge = Mid(sBolge, 2)

        xDizi = Split(sBolge, ",")

        xOran = Application.WorksheetFunction.RoundUp(xSay / xMesai, 0)



        For x = 0 To UBound(xDizi) Step xOran

            Cells(xSatir - 1, CLng(xDizi(x))).Value = 1

            xMesai = xMesai - 1

            xSay = xSay - 1

        Next x

        sBolge = ""

        For x = 4 To 34

            If Cells(xSatir, x).Value = "X" And Len(Trim(Cells(xSatir - 1, x))) = 0 Then sBolge = sBolge & "," & x

        Next x

        If Len(Trim(sBolge)) = 0 Then Exit Do

        

    Loop

End If

End Sub

[attachment=30889]

(27/11/2019, 12:28)berduş yazdı: Aşağıdaki kod işinize yarayabilir, denemelerimde sorun çıkarmadı
0-31 aradı denedim, çalıştığı günden fazla mesai eklenirse uyarı veriyor
Dilerim işinize yarar
Not: sonucları kontrol etmek icin imza alanını geçici olarak değiştirdim.
Imza alanını eski haline getirebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim xStun As Range

Dim xSay, xSatir As Long

Dim xOran, xMesai, y As Integer

Dim sBolge As String

Dim xDizi() As String



Set xStun = Range("AK:AK")



If Not Application.Intersect(xStun, Range(Target.Address)) Is Nothing Then



    

    sBolge = ""

    xMesai = Target.Value

    xSatir = Target.Row + 1

    xSay = Application.WorksheetFunction.CountIf(Range("D" & xSatir & ":Ah" & xSatir), "X")

    If xSay < xMesai Then

        MsgBox ("mesai saati ( " & xMesai & " saat) çalıştığı günden ( " & xSay & " gün ) fazla. Mesai saatini düzeltin")

        Exit Sub

    End If

    Range("D" & xSatir - 1 & ":Ah" & xSatir - 1).ClearContents



    For x = 4 To 34

        If Cells(xSatir, x).Value = "X" Then sBolge = sBolge & "," & x

    Next x



    Do While xMesai > 0

      

        sBolge = Mid(sBolge, 2)

        xDizi = Split(sBolge, ",")

        xOran = Application.WorksheetFunction.RoundUp(xSay / xMesai, 0)



        For x = 0 To UBound(xDizi) Step xOran

            Cells(xSatir - 1, CLng(xDizi(x))).Value = 1

            xMesai = xMesai - 1

            xSay = xSay - 1

        Next x

        sBolge = ""

        For x = 4 To 34

            If Cells(xSatir, x).Value = "X" And Len(Trim(Cells(xSatir - 1, x))) = 0 Then sBolge = sBolge & "," & x

        Next x

        If Len(Trim(sBolge)) = 0 Then Exit Do

        

    Loop

End If

End Sub

Teşekkür Ederim. Kontrol edip size geri dönüş yaparım

(28/11/2019, 11:14)ByChilavert yazdı:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim xStun As Range

Dim xSay, xSatir As Long

Dim xOran, xMesai, y As Integer

Dim sBolge As String

Dim xDizi() As String



Set xStun = Range("AK:AK")



If Not Application.Intersect(xStun, Range(Target.Address)) Is Nothing Then



    

    sBolge = ""

    xMesai = Target.Value

    xSatir = Target.Row + 1

    xSay = Application.WorksheetFunction.CountIf(Range("D" & xSatir & ":Ah" & xSatir), "X")

    If xSay < xMesai Then

        MsgBox ("mesai saati ( " & xMesai & " saat) çalıştığı günden ( " & xSay & " gün ) fazla. Mesai saatini düzeltin")

        Exit Sub

    End If

    Range("D" & xSatir - 1 & ":Ah" & xSatir - 1).ClearContents



    For x = 4 To 34

        If Cells(xSatir, x).Value = "X" Then sBolge = sBolge & "," & x

    Next x



    Do While xMesai > 0

      

        sBolge = Mid(sBolge, 2)

        xDizi = Split(sBolge, ",")

        xOran = Application.WorksheetFunction.RoundUp(xSay / xMesai, 0)



        For x = 0 To UBound(xDizi) Step xOran

            Cells(xSatir - 1, CLng(xDizi(x))).Value = 1

            xMesai = xMesai - 1

            xSay = xSay - 1

        Next x

        sBolge = ""

        For x = 4 To 34

            If Cells(xSatir, x).Value = "X" And Len(Trim(Cells(xSatir - 1, x))) = 0 Then sBolge = sBolge & "," & x

        Next x

        If Len(Trim(sBolge)) = 0 Then Exit Do

        

    Loop

End If

End Sub

Teşekkür Ederim. Sorunsuz bir şekilde işlem yapıyor. 1-1-1-1 yerine 3-3-3 olarak dağıtması için nasıl bir işlem yapmam lazım

Kodun en başına Dim satırlarının olduğu yere yeni bir tanımlayıcı ekleyip

dim satış as integer

yazın. Sonra da

For x = 0 To UBound(xDizi) Step xOran

            Cells(xSatir - 1, CLng(xDizi(x))).Value = 1

            xMesai = xMesai - 1

            xSay = xSay - 1

        Next x

yukardaki bloğunu asagidakiyle değiştirip deneyin

For x = 0 To UBound(xDizi) Step xOran

            Cells(xSatir - 1, CLng(xDizi(x))).Value = xArtis

            xMesai = xMesai - xArtis

            xSay = xSay - 1

        Next x

1 2 3 4 5 6