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

حرب التعديل التالي توزيع عدد الحصص (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

عند فتح الشيت اضغظ مباشرة على الزرين في نفس الوقت ولا تحدد اي خلايا او استخدم الكود بالملف 5000_A3.xlsb

وعليكم السلام ورحمة الله وبركاته اضغط على مفتاحي Ctrl + ~ (المفتاح الذي فوق Tab)

وعليكم السلام ورحمة الله وبركاته بالنسبة للاوقات التي خارج الاوقات في M&N لم تحدده وفي اي بصمة تسجل تم ربط المعادلات حسب الاوقات في M&N اكسل1.xlsm

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

السلام عليكم نعم المشكلة من حماية الشيتات اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل Plateform (1) .xlsb