توزيع عدد الحصص الزيادة للمعلم على مدار الاسبوع

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

استبدل الكود التالي بالكود بالملف

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

 

[بلانك]

شكرا علر الرد :  لكن المطلوب توزيع الحصص على مدار الاسبوع ( 5 ايام)   اي لو عندي 5 حصص زيادة يتم توزيعهم الحصة الثامنة من كل يوم الاحد حصة والاثنين حصة وهكذا .... ولو 6 حصص زيادة  يكون الاحد الحصة السابعة حصة والثامنة حصة وباقي الايام حصة وهكذا

[بلانك]