مدموج :الرجاء اخوان المساعده في ملف نتائج طلبه

Sub Test()

    Const iSuccess As Integer = 50

    Dim e, lr As Long, r As Long, mrk As Double, t As Double

    Application.ScreenUpdating = False

        With ActiveSheet

            lr = .Cells(Rows.Count, 1).End(xlUp).Row

            .Range("B2:H" & lr).Copy .Range("J2")

            For r = 3 To lr

                mrk = 10: t = 0

                For Each e In Array(13, 14, 15, 16, 12, 11)

                    With .Cells(r, Val(e))

                        If .Value < iSuccess And .Value >= (iSuccess - 10) And mrk >= 1 Then

                            t = mrk

                            mrk = mrk - (iSuccess - .Value)

                            If mrk >= 0 Then .Value = Application.WorksheetFunction.Min(.Value + t, iSuccess)

                            If mrk = 0 Then Exit For

                        End If

                    End With

                Next e

            Next r

        End With

    Application.ScreenUpdating = True

End Sub