makro düzenleme

[HANEDANNN]

atacagım makro kodunda aylık 46 ıncı satıra kadar olan personele otomatik mesai atıyor ,ama ben aylık olarak personel sayısını değiştirecegim için bazen 40,43 veya 42 olarak değişecek satırlar ama değiştiremedim,yardımcı olur musunuz

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ilk As Date, son As Integer, sut As Integer
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
ilk = WorksheetFunction.EoMonth(Target, -1) + 1
son = Day(WorksheetFunction.EoMonth(Target, 0))
Range(Cells(1, son + 2), Cells(1, 32)).ClearContents
If son < 31 Then Range(Cells(2, son + 2), Cells(46, 32)).ClearContents
For sut = 2 To son + 1
Cells(1, sut) = ilk + sut - 2
Next
End Sub

Sub NOBET_DAGIT()
Dim sonG As Byte, g As Byte, sy As Byte, XD As Byte

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
sonG = Day(WorksheetFunction.EoMonth([A1], 0))
If sonG < 31 Then Range(Cells(2, sonG + 2), Cells(46, 32)).ClearContents
On Error Resume Next
For g = 2 To 32
sy = WorksheetFunction.CountIf(Range(Cells(2, g), Cells(46, g)), 16)
If Cells(1, g).Value = "" Then Exit For
10: If sy = 12 Then GoTo 20
Randomize: XD = Int(Rnd * 46) + 1: If XD = 1 Then GoTo 10
If WorksheetFunction.CountIf(Range("B" & XD & ":AF" & XD), 16) >= 9 Then GoTo 10
If Cells(XD, g - 1) = 16 Or Cells(XD, g) <> "" Then GoTo 10
If Cells(XD, g + 1) <> "" And g <> 32 Then GoTo 10
If Cells(XD, g - 1) <> 16 And Cells(XD, g) = Empty And sy + 1 < 13 Then
sy = sy + 1: Cells(XD, g) = 16
End If
20: If sy < 12 Then GoTo 10
Next
For g = 2 To 32
sy = WorksheetFunction.CountIf(Range(Cells(2, g), Cells(46, g)), 8)
If Cells(1, g).Value = "" Then Exit For
30: If sy = 12 Then GoTo 40
Randomize: XD = Int(Rnd * 46) + 1: If XD = 1 Then GoTo 30
If WorksheetFunction.CountIf(Range("B" & XD & ":AF" & XD), 8) >= 9 Then GoTo 30
If Cells(XD, g - 1) <> 16 And Cells(XD, g) <> Empty Then GoTo 30
If Cells(XD, g - 1) <> 16 And Cells(XD, g) = Empty And sy + 1 < 13 Then
sy = sy + 1: Cells(XD, g) = 8: GoTo 30
End If
40: If sy < 12 Then GoTo 30
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox " İşlem tamamlandı " & vbLf & _
vbLf & " ABC ", vbInformation + vbMsgBoxRtlReading, "..:: ABC ::.."
End Sub

Sub TEMIZLE()
Range("B2:AF46").ClearContents
End Sub

 

[EmrExcel16]

Verdiğiniz kod da "46" yazan yerleri istediğiniz sayıları yazarak denediniz mi ?

 

[HANEDANNN]

Evet denedim ama çalıştırınca donuyor hata veriyor

 

[HANEDANNN]

Nasıl bir yol izlemeliyim

 

[systran]

örnek veri ile dolu bir çalışma sayfası yüklerseniz belki çözüm bulan olabilir.