نجوم المشاركات

من الاشياء التي تم تصحيحها : كان موجود كود يعيد اي تاريخ من هذا الشهر الى اليوم الأول وهذا يعتبر عمل غير موافق للحقيقة .. اذا الادخال في يوم 15 يجب ان يسجل في 15 لذا جعلت الكود يقبل التسديد في اي يوم من الشهر فالعمدة هو الشهر الحالي .. لا فرق بين اوله وآخره

وعليكم السلام ورحمة الله وبركاته جرب الكود في الملف المرفق 1الجرد.xlsm

اخي الكريم ذكرت انظر في الكود في فورم FrmTransfer1 بينما البرنامج يفتح على FrmTransfer والكود cmd_Pay_installments موجود في النموذجين لا اخفيك تهت .. اذا العمل على FrmTransfer1 لماذا FrmTransfer موجود ؟ اذا يوجد ازرار غير مهمة احذفها .. هذا مجرد مثال

بارك الله فيك وزادك من فضله

ممكن يكون طلبك هنا https://www.youtube.com/watch?v=M1DhpzkT8kA او جرب هذا الكود: Sub Observer_FullSystem() Dim ws As Worksheet, wsReport As Worksheet Dim NamesArr() As Variant Dim UsedRow As Object, UsedCol As Object, UsedAll As Object Dim lrNames As Long, lrRows As Long, lrCols As Long Dim r As Long, c As Long, i As Long Dim Available() As String Dim cnt As Long, MaxAllowed As Long, TotalCells As Long Dim TryCount As Long Dim MainCols As Long: MainCols = 2 ' عدد الأعمدة الأساسية Set ws = ActiveSheet Application.ScreenUpdating = False Randomize ' ===== Backup ===== ws.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Backup_" & Format(Now, "ddmmyy_hhmmss") ws.Activate ' ===== قراءة الأسماء ===== lrNames = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row NamesArr = ws.Range("B3:B" & lrNames).Value ' ===== حدود الجدول ===== lrRows = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row lrCols = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)).ClearContents ' ===== الحد الأقصى ===== TotalCells = (lrRows - 2) * (lrCols - 3) MaxAllowed = Application.WorksheetFunction.RoundUp(TotalCells / (lrNames - 2), 0) Set UsedAll = CreateObject("Scripting.Dictionary") ' ===== التوزيع ===== For r = 3 To lrRows Set UsedRow = CreateObject("Scripting.Dictionary") For c = 4 To lrCols TryCount = 0 RetryCell: TryCount = TryCount + 1 If TryCount > 300 Then GoTo NextCell Set UsedCol = CreateObject("Scripting.Dictionary") For i = 3 To r - 1 If ws.Cells(i, c).Value <> "" Then UsedCol(ws.Cells(i, c).Value) = 1 Next i cnt = 0 ReDim Available(1 To UBound(NamesArr, 1)) For i = 1 To UBound(NamesArr, 1) If Not UsedRow.exists(NamesArr(i, 1)) _ And Not UsedCol.exists(NamesArr(i, 1)) Then If Not UsedAll.exists(NamesArr(i, 1)) _ Or UsedAll(NamesArr(i, 1)) < MaxAllowed Then cnt = cnt + 1 Available(cnt) = NamesArr(i, 1) End If End If Next i If cnt > 0 Then ws.Cells(r, c).Value = Available(Int(Rnd * cnt) + 1) UsedRow(ws.Cells(r, c).Value) = 1 UsedAll(ws.Cells(r, c).Value) = UsedAll(ws.Cells(r, c).Value) + 1 Else GoTo RetryCell End If NextCell: Next c Next r ' ===== تقرير ===== On Error Resume Next Set wsReport = Sheets("تقرير") On Error GoTo 0 If wsReport Is Nothing Then Set wsReport = Sheets.Add wsReport.Name = "تقرير" Else wsReport.Cells.Clear End If wsReport.Range("A1:D1") = Array("الاسم", "الإجمالي", "أساسي", "احتياطي") For i = 3 To lrNames wsReport.Cells(i - 2, 1) = ws.Cells(i, 2) wsReport.Cells(i - 2, 2) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 3) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, 3 + MainCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 4) = wsReport.Cells(i - 2, 2) - wsReport.Cells(i - 2, 3) Next i wsReport.Columns.AutoFit Application.ScreenUpdating = True MsgBox "تم التوزيع + إنشاء نسخة احتياطية + تقرير كامل ?", vbInformation End Sub

وعليكم السلام ورحمة الله وبركاته .. بدايةً اسم الحقل = "id_pers" وليس "رقم التسجيل" صحيح ؟؟ اعتقد انك تستطيع استعمال الدالة DMAX كقيمة افتراضية لمربع النص داخل النموذج . كمثال ، اجعل القيمة الإفتراضية لمربع النص id_pers تساوي الجملة التالية وجرب بعد أن تقوم بحذف السجل الموجود في جدولك :- =Nz(DMax("id_pers","tbl_personne1"),19020999)+1 ملفك بعد التعديل :- IsertImages.zip