مسح نطاق واحد في عدة أوراق عمل والترقيم بالأكواد (تبييض النتيجة)

[أيمن ابراهيم]

السادة الزملاء اعضاء وخبراء المنتدى

السلام عليكم ورحمة الله وبركاته

المطلوب المساعدة والتعديل على كود الترحيل بالملف المرفق فيما يلي :-

اولاً : هل توجد طريقة اخرى لكتابة امر مسح النطاق المرحل الية البيانات في شيتات الترحيل المختلفة كما هو موضح بالصورة المرفقة ، علماً بأن نطاق مسح البيانات واحد في جميع شيتات الترحيل وهو ( B10 : By819 ) .

ثانياً : في العمود ( A )  في شيتات الترحيل توجد دالة ترقيم تلقائي

المطلوب التعديل على كود الترحيل واضافة خاصية الترقيم الى كود الترحيل ، بدلا من دالة الترقيم التلقائي

ولكم منى وافر التحية والاحترام

 

ayman.rar

[ياسر خليل أبو البراء]

أخي الغالي أيمن إبراهيم

إليك الكود التالي عله يكون المطلوب

Sub Ayman_Trheel_TBYED()

    Dim SH As Worksheet, I As Long, S As Long, CL As Range
    S = 1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each SH In Worksheets
        If SH.Name <> "الشيت" Then SH.Range("A10:BY819").ClearContents
    Next SH

    For I = 2 To 7
        For Each CL In Range("CC6:CC" & [CC1000].End(xlUp).Row)

            If CL.Value = Sheets(I).Name Then
                CL.Offset(0, -79).Resize(1, 76).Copy

                If I = 5 Then
                    S = 2
                End If

                Sheets(I).Range("B" & Sheets(I).[B1000].End(xlUp).Row + S).PasteSpecial xlPasteValues
                With Sheets(I).Range("A10:A" & Sheets(I).[B1000].End(xlUp).Row)
                    .Formula = "=+IF(I10="""","""",SUBTOTAL(3,I$10:I10))"
                    .Value = .Value
                End With

            End If
        Next
    Next

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "تم ترحيل الطلبة الناجحــون والـدور الثـاني للتبيـيض بنجاح ", vbOKOnly, "الحمـــد لله"

End Sub

تقبل تحيات تلميذكم ياسر

[أيمن ابراهيم]

أخي الغالي أيمن إبراهيم

إليك الكود التالي عله يكون المطلوب

Sub Ayman_Trheel_TBYED()

    Dim SH As Worksheet, I As Long, S As Long, CL As Range
    S = 1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each SH In Worksheets
        If SH.Name <> "الشيت" Then SH.Range("A10:BY819").ClearContents
    Next SH

    For I = 2 To 7
        For Each CL In Range("CC6:CC" & [CC1000].End(xlUp).Row)

            If CL.Value = Sheets(I).Name Then
                CL.Offset(0, -79).Resize(1, 76).Copy

                If I = 5 Then
                    S = 2
                End If

                Sheets(I).Range("B" & Sheets(I).[B1000].End(xlUp).Row + S).PasteSpecial xlPasteValues
                With Sheets(I).Range("A10:A" & Sheets(I).[B1000].End(xlUp).Row)
                    .Formula = "=+IF(I10="""","""",SUBTOTAL(3,I$10:I10))"
                    .Value = .Value
                End With

            End If
        Next
    Next

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "تم ترحيل الطلبة الناجحــون والـدور الثـاني للتبيـيض بنجاح ", vbOKOnly, "الحمـــد لله"

End Sub

تقبل تحيات تلميذكم ياسر

استــاذى الفاضل ابوالــــبراء

اشكرك على اهتمامك بتلاميذك المخلصين 

تعديل الكود المرفق من سيادتكم هو المطلوب بالفعل

تقبل تحيــــات تلميذك 

لك منى كل الشكر والتقدير

تم تعديل يونيو 4, 2015 بواسطه أيمن ابراهيم

[أيمن ابراهيم]

مشرفنا الغالي أبو الــــبراء

اطمع في شرح بسيط لاتعديل الذى تم على الكود

اتمنى من الله بأن اكون لا اثقل عليك بكثرة طلباتي

تفبل تحياتي

[ياسر خليل أبو البراء]

 

مشرفنا الغالي أبو الــــبراء

اطمع في شرح بسيط لاتعديل الذى تم على الكود

اتمنى من الله بأن اكون لا اثقل عليك بكثرة طلباتي

تفبل تحياتي

 

الوقت لن يسعني الآن أخي الحبيب أيمن

إن شاء الله حينما يتسع الوقت لدي سأقوم بالشرح

 

حاول تشوف الأجزاء الصعبة في فهمها وإن شاء الله نحاول نبسطها لك