كود مسح صفوف محددة في عدة صفحات

[ابن بنها]

بسم الله الرحمن الرحيم

اولا : جزاكم الله خيرا وبارك فيكم

ثانيا : هذا مرفق به كود راائع للاستاذ ياسر خليل لنسخ صفوف محدده في صفحات مختلفة

المطلوب

ايجاد كود يمسح هذه الصفوف الموجوده  في الصفحات المختلفه ...

طبعا هيترك صف البدايه اللي هينسخ منه

نسخ صفوف بالعدد في صفحات مختلفه.rar

[قصي]

نشكر السائل و المحيب 

جزاكم الله خيرا

[ابن بنها]

للرفع .... رفع الله مقداركم

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

أخي الكريم ابن بنها

إليك رابط الموضوع التالي فيه شرح تفصيلي للمطلوب وإن شاء الله يفيدك ..

الرابط من هنا

[ابن بنها]

Sub TestRun()
    DeleteRow "Sheet1", 10
End Sub

Sub DeleteRow(sSheet As String, sRow As Long)
    Dim Ws As Worksheet
    Dim cnt As Long

    On Error Resume Next
        Set Ws = Sheets(sSheet)
    On Error GoTo 0

    If Ws Is Nothing Then
        MsgBox "Sheet " & sSheet & "  Doesn't Exist.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
        cnt = Sheets("Data").Range("G7").Value
        Ws.Rows(sRow & ":" & (sRow + cnt - 1)).Delete
    Application.ScreenUpdating = True
End Sub

اكمل جميلك وضعه في المرفق

اليس هذا الكود يمسح صفوف في ورقة واحده ام اوراق متعدده

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

قم بالتعديل على الكود بما يتاسب مع ملفك أخي الكريم ..

الأمر مشروح بالتفصيل في الموضوع .. وتعمدت التفصيل لكي تتعلم كيف يمكنك استخدامه ..

تعلم الصيد لأنني لن أعطي أسماكاً بعد اليوم

[ابن بنها]

Sub TestRun()
    DeleteRow "بيانات الطلبة", 7
        DeleteRow "إنجاز1", 7
        DeleteRow "تحريرى ف 1", 7
        DeleteRow "رصد الترم الأول", 7
        DeleteRow "أعمال السنة", 7
                DeleteRow "تحريرى ف 2", 7
        DeleteRow "رصد الترم الثانى", 7
        DeleteRow "كنترول شيت", 11


End Sub

Sub DeleteRow(sSheet As String, sRow As Long)
    Dim Ws As Worksheet
    Dim cnt As Long

    On Error Resume Next
        Set Ws = Sheets(sSheet)
    On Error GoTo 0

    If Ws Is Nothing Then
        MsgBox "Sheet " & sSheet & "  Doesn't Exist.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
        cnt = Sheets("بيانات المدرسة").Range("G7").Value
        Ws.Rows(sRow & ":" & (sRow + cnt - 1)).Delete
    Application.ScreenUpdating = True
End Sub

ربنا يبارك لك ... ولكن يوجد اهتزاز قوي بالشاشه اثناء اجراء تنفيذ الكود

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

ضع السطر التالي في الكود المسمى TestRun في البداية

  Application.ScreenUpdating = False

وفي نهاية الكود

  Application.ScreenUpdating = True

 

[ابن بنها]

بعد السطر الكام يا اخي الكريم لاني الاحظ وجود السطرين السابقين

الهزة شديده

 

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

[ناصر سعيد]

تحيه للاستاذ   الكبير ياسر خليل

جزاك الله كل خير  ..

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

أخي الفاضل ناصر سعيد

بارك الله فيك وجزاك الله خيراً لمرورك العطر

أخي الكريم ابن بنها

أنا مش عارف ليه إنت معقد الأمور أكتر من اللازم Take It Easy

أنا قلت لك أول سطر ... وآخر سطر .. (السطر اللي فيه اسم الإجراء دا طبيعي معروف والأخير اللي فيه كلمة End Sub دي القفلة ..يعني مليش دعوة بيهم)

شوف المفروض يكون بالشكل ده

Sub TestRun()
    Application.ScreenUpdating = False
        DeleteRow "بيانات الطلبة", 7
        DeleteRow "إنجاز1", 7
        DeleteRow "تحريرى ف 1", 7
        DeleteRow "رصد الترم الأول", 7
        DeleteRow "أعمال السنة", 7
        DeleteRow "تحريرى ف 2", 7
        DeleteRow "رصد الترم الثانى", 7
        DeleteRow "كنترول شيت", 11
    Application.ScreenUpdating = True
End Sub

بس خلاص ...شفت الموضوع مش صعب إزاي

[ابن بنها]

'
'

'
Sub ClearContents()
        Application.ScreenUpdating = False

    Range("E7:O7").Select
    Selection.ClearContents
    Sheets("إنجاز1").Select
    Range("C7:L7").Select
    Selection.ClearContents
    Sheets("تحريرى ف 1").Select
    Range("D7:N7").Select
    Selection.ClearContents
    Sheets("تحريرى ف 2").Select
    Range("C7:N7").Select
    Selection.ClearContents
        Sheets("أعمال السنة").Select
    Range("C7:L7").Select
    Selection.ClearContents

    Sheets("بيانات الطلبة").Select
    Range("B7").Select
            Application.ScreenUpdating = True

End Sub

اخي الكريم كود مسحك ممتاز وساجرب اضافتك ان شاء الله وبعد ... كود مسحك المفروض يمسح من الصف الثامن يعني بنترك صف دائما لكي ننسخ منه  وهو يعمل تمام

ويتبقى بعض الادخالات في صفحات معينه في الصف السابع وعملت هذا الكود على قدي لكي يمسح ادخالات الصف السابع  من الارقام فقط

اريد ادخال هذا الكود مع كودكم للمسح يعني يمس الصفوف بكودك ويكمل مسح الارقام الموجوده فيي الصف السابع

فاذا رايت فكره تؤدي المطلوب موافق ربنا يجزيك خيرا

 

 

 

 

 

 

 

 

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

أعتقد أن كود النسخ الذي ينسخ لجميع أوراق العمل يقوم بعملية المسح التي تقصدها ..

تعني أن المسح يكون في الصف السابق للصف الهدف ..أي أنك إذا كتبت الصف رقم 8 .. تريد مسح البيانات كلها من الصف رقم 7

لا تنسى أنني أتحدث عن الإجراء الفرعي المخصص الآن

DeleteRow "Sheet1",8

الصف الهدف أي بداية الحذف للصفوف وليس المسح يكون من الصف رقم 8 ... فهل المطلوب أن يتم مسح الصف السابق ألا وهو في هذه الحالة الصف رقم 7 .. وهل لمسح لجميع البيانات أم للقيم الثابتة فقط والإبقاء على المعادلات ..؟؟؟؟

 

[ناصر سعيد]

هذا الموضوع يهم فئات كثيره من المعلمين

معذره اخي ابن بنها

يتم بكودك حذف الصفوف من الصف الثامن

طيب الصف السابع فيه معادلات وفيه تنسيقات وفيه ايضا اسماء طلبه وارقام درجاتهم

المطلوب مسح الارقام والاسماء فقط يعني نسيب خطوط الصف السابع و معادلاته وتنسيقاته

حتى يتم ادخالات جديده اسماء جديده وارقام جديده

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

حسب الملف المرفق في المشاركة الأولى إليكم الكود التالي ..

والأفضل أن تدرسوا الكود بعناية لتتمكنوا من التعديل عليه بما يتلائم مع ملفاتكم

Sub TestRun()
    Application.ScreenUpdating = False
        DeleteRow "بيانات الطلبة", 8
        DeleteRow "إنجاز1", 8
        DeleteRow "تحريرى ف 1", 8
        DeleteRow "رصد الترم الأول", 8
        DeleteRow "أعمال السنة", 8
        DeleteRow "تحريرى ف 2", 8
        DeleteRow "رصد الترم الثانى", 8
        DeleteRow "كنترول شيت", 12
    Application.ScreenUpdating = True
End Sub

Sub DeleteRow(sSheet As String, sRow As Long)
    Dim Ws As Worksheet
    Dim cnt As Long

    On Error Resume Next
        Set Ws = Sheets(sSheet)
    On Error GoTo 0

    If Ws Is Nothing Then
        MsgBox "Sheet " & sSheet & "  Doesn't Exist.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If

    Application.ScreenUpdating = False
        On Error Resume Next
        Ws.Rows(sRow - 1).SpecialCells(xlCellTypeConstants, 3).ClearContents
        cnt = Sheets("بيانات المدرسة").Range("B10").Value
        Ws.Rows(sRow & ":" & (sRow + cnt - 2)).Delete
    Application.ScreenUpdating = True
End Sub

 

 

[ابن بنها]

ربنا يجزيك خيرا .. استاذ ياسر خليل

[ابن بنها]

هذا هو المرفق النهائي وبه كود النسخ وكود المسح

معذرة استاذ ياسر كود المسح مفييييد ولكن مازالت الهزه

 

نسخ صفوف بالعدد في صفحات مختلفه.rar

[ناصر سعيد]

الأستاذ الكبير ياسر خليل

جزاك الله كل خير

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

وجزيت خيراً أخي الفاضل ناصر سعيد بمثل ما دعوت لي وزيادة

أخي الكريم ابن بنها لا أعرف سبب الهزة التي تتحدث عنها ربما إمكانيات الجهاز ضعيفة جداً مما يشكل عبء على الجهاز والله أعلم .. لكن الهزة من المفترض أن يعالجها الأسطر التي أشير إليك فيها في المشاركات السابقة

[ناصر سعيد]

كود روعه .. ربنا يحفظك يا استاذ ياسر خليل

[قصي]