عبدالله بشير عبدالله

وغليكم السلام ورحمة الله وبركاته الصورة وحدها لا تكفي لتحديد المشكلة، لأن الخطأ مرتبط بمحتوى الملف نفسه (مثل عناصر التحكم أو كود VBA). يرجى إرسال الملف حتى يمكن فحصه بدقة.

السلام عليكم جرب التعديل التالي طلب تعديل كود.xlsm

وعليكم السلام ورحمة الله وبركاته حسب فهمي لطلبك اليك المطلوب طباعة مع ترقيم الصفحة.xlsm

السلام عليكم بعد اذن استاذنا ابو مروان اليك تعديل زر الترحيل باستخدام المصفوفات Sub AddEmployee() Dim ws1 As Worksheet, ws2 As Worksheet Dim nextRow As Long, i As Long Dim srcRange As Variant Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") If ws1.Range("I9").Value = "" Then MsgBox "يرجى إدخال اسم الموظف!", vbExclamation, "تنبيه" Exit Sub End If nextRow = ws2.Cells(ws2.Rows.Count, "C").End(xlUp).Row + 1 srcRange = Array("I5", "I7", "I9", "I11", "I13", "L11", "L13", "I15", "L15", _ "L5", "L7", "L9", "I19", "L19", "I21", "L21", "I23", "L23", _ "I25", "L25", "I28", "L28", "L30", "I33", "L33", "I35", "L35", _ "I37", "I40", "L40", "I44", "L44", "I46", "L46", "I48", "L48", _ "I50", "L50", "I52", "L52", "L55") For i = LBound(srcRange) To UBound(srcRange) ws2.Cells(nextRow, i + 1).Value = ws1.Range(srcRange(i)).Value Next i MsgBox "تمت إضافة الموظف بنجاح!", vbInformation, "نجاح" End Sub بسم الله.xlsm

حرب التعديل التالي توزيع عدد الحصص (233) (1).xlsm

استبدل الكود التالي بالكود بالملف Sub DrawCircles1() Application.ScreenUpdating = False Call DelShap Call ProcessTable(10, 14, 3, 10, "N9") Call ProcessTable(18, 22, 3, 10, "N17") Application.ScreenUpdating = True End Sub Sub ProcessTable(SROW As Long, EROW As Long, SCOL As Long, ECOL As Long, RefCell As String) Dim ws As Worksheet Dim i As Long, j As Long Dim totalCells As Long, totalRequired As Long Dim dayCells As Long, n As Long Dim arrCells() As Long Dim temp() As Double Dim remainder As Long Set ws = ActiveSheet totalRequired = Val(ws.Range(RefCell).Value) totalCells = 0 ReDim arrCells(SROW To EROW) ReDim temp(SROW To EROW) For i = SROW To EROW dayCells = 0 For j = SCOL To ECOL If Trim(ws.Cells(i, j).Value) <> "" Then dayCells = dayCells + 1 End If Next j arrCells(i) = dayCells totalCells = totalCells + dayCells Next i If totalCells = 0 Then Exit Sub For i = SROW To EROW If arrCells(i) > 0 Then temp(i) = totalRequired * arrCells(i) / totalCells Else temp(i) = 0 End If Next i For i = SROW To EROW n = Int(temp(i)) If n > arrCells(i) Then n = arrCells(i) If n = 0 Then ws.Range("M" & i).Value = "" Else ws.Range("M" & i).Value = n End If Next i remainder = totalRequired - Application.WorksheetFunction.Sum(ws.Range("M" & SROW & ":M" & EROW)) Do While remainder > 0 Dim maxI As Long, maxVal As Double maxVal = -1 For i = SROW To EROW If arrCells(i) > Val(ws.Range("M" & i).Value) Then If temp(i) - Int(temp(i)) > maxVal Then maxVal = temp(i) - Int(temp(i)) maxI = i End If End If Next i If ws.Range("M" & maxI).Value = "" Then ws.Range("M" & maxI).Value = 1 Else ws.Range("M" & maxI).Value = ws.Range("M" & maxI).Value + 1 End If remainder = remainder - 1 Loop For i = SROW To EROW n = Val(ws.Range("M" & i).Value) If n > 0 Then Dim validCols() As Long Dim countCols As Long countCols = 0 For j = SCOL To ECOL If Trim(ws.Cells(i, j).Value) <> "" Then countCols = countCols + 1 ReDim Preserve validCols(1 To countCols) validCols(countCols) = j End If Next j Dim k As Long For k = countCols To 1 Step -1 If n = 0 Then Exit For j = validCols(k) With ws.Shapes.AddShape(msoShapeOval, _ ws.Cells(i, j).Left + 5, _ ws.Cells(i, j).Top + 5, _ ws.Cells(i, j).Width - 10, _ ws.Cells(i, j).Height - 10) .Line.Weight = 2 .Fill.Visible = msoFalse End With n = n - 1 Next k End If Next i End Sub

لديك الحق استبدل في الكود wsSource.Range("A4:I4").ClearContents الى wsSource.Range("A7:I7").ClearContents بمعنى الرقم 4 غيره الى 7 فقط

وعليكم السلام نعم اعلم ان هناك طلب ثاني وكان ردي السابق لطلبك الاول اليك الملف وبه طلبك الثاني Plateform19840019.xlsb

وعليكم السلام ورحمة الله وبركاته الحل قم بتحديث اوفيس2007 الى 2010 او احدث فالامر بسيط عند اول محل كمبيوتر اما بالنسبة لطلبك الاول تعديل كود الترحيل اليك الملف Plateform19840019.xlsb

جرب التعديل التالي توزيع عدد الحصص (233) (1).xlsm

نعم حمل الملف مرة اخرى من المشاركة السابقة تم التعديل ان شاء الله ولا حرج ياخي فكلنا تنعلم

التوزيع بالكود مغ زر رسم الدوائر توزيع عدد الحصص (233) (1).xlsm

استبدل المعادلة الاولى بالثانية في M10 واسحب لاسفل =IF(COUNTIF(C10:J10;"*")>0;1;0) =IF(SUMPRODUCT(--(C10:J10<>""))>0;1;0)

السلام عليكم بالرغم عدم استيعابي للامر جيدا اليك المحاولة حيث تم ادراج معادلات في عمود مساعد في العمود l وذلك لمعرفة الايام التي ليس بها حصص كذلك تم تعديل المعادلات يمكن سحبها للاسفل لنفس الجدول بدل كتابة كل خلية معادلة خاصة بها مثال للتوضح والمطلوب - 222.xlsm