28/11/2019, 15:41
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?