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

    

    If Target.Value Mod 3 <> 0 Then

        MsgBox ("Mesai saati 3'ün tam katı değil")

        Exit Sub

    End If

    

    sBolge = ""

    xMesai = Target.Value / 3

    xSatir = Target.Row + 1

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

  

    If Round(xSay / 3) < xMesai Or xMesai * 3 > 21 Then

        MsgBox ("mesai saati ( " & xMesai * 3 & " saat) çalıştığı günle ( " & xSay & " gün ) orantılı degil yada 21'den 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 = 3

            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

Kodu yukardakiyle değiştirip dener misiniz?