تعديل كود ترحيل بيانات من صفحة إلى أخرى بشرط

[عزيز عرابي]

السادة خبراء المنتدى المحترمين ,,,

 

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

يرجى التكرم و مساعدتي في الكود الموجود في المرفق

 

الكود يقوم بنسخ الأسطر في الصفحة الأولى "Sheet1" إلى صفحتين بحسب الشرط الذي هو أن يقوم بنسخ الأسطر من الصفحة الأولى التي تحتوي على رقم سالب في العمود E إلى الصفحة الثالثة "Sheet3" و يقوم بنسخ الأسطر من الصفحة الأولى التي تحتوي على رقم موجب في العمود E إلى الصفحة الثالثة "Sheet2" 

 

و بذلك يكون الكود فصل بين الاسطر الارقام ذات السالبة و الاسطر ذات الارقام الموجبة بكل منها في صفحة منفصلة

 

ما أريده من حضرتكم نعديل الكود ليقوم مسح مجتويات الصفحتين الثانية "Sheet2"  و الثالثة  "Sheet3" و ذلك قبل اجراء عملية النسخ من الصفحة الاولى

 

بمعنى ان يتم مسح محتويات الصفحتين "Sheet2" و "Sheet3" قبل اجراء عملية نسخ الاسطر ذات القيمة الموجبة في العمود E إلى الصفحة الثانية و قبل نسخ الاسطرذات القيمة السالبة في العمود E إلى الصفحة الثالثة 

 

مع محبتي و شكري

 

هذا الكود

 

Sub FilterAndCopy()

 

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.Calculation = xlCalculationManual

 

 

Dim lngLastRow As Long

Dim OKSheet As Worksheet, ErrorSheet As Worksheet

 

Set OKSheet = Sheets("Sheet2") ' Set This to the Sheet name you want all Ok's going to

Set ErrorSheet = Sheets("Sheet3") ' Set this to the Sheet name you want all Error's going to

 

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

 

 

With Range("A1", "E" & lngLastRow)

    .AutoFilter

    .AutoFilter Field:=5, Criteria1:=">0"

    .Copy OKSheet.Range("A1")

    .AutoFilter Field:=5, Criteria1:="<0"

    .Copy ErrorSheet.Range("A1")

    .AutoFilter

End With

 

 

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

 

End Sub

 

 

Book1.rar

[عزيز عرابي]

للرفع

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

أخي الكريم عزيز عرابي

إليك هذا التعديل البسيط

Sub FilterAndCopy()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
        Dim lngLastRow As Long
        Dim OKSheet As Worksheet, ErrorSheet As Worksheet
        
        Set OKSheet = Sheets("Sheet2")
        Set ErrorSheet = Sheets("Sheet3")
        lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
        
        'مسح محتويات النطاق الذي سيتم إدراج النتائج به
        OKSheet.Columns("A:E").ClearContents
        ErrorSheet.Columns("A:E").ClearContents
        
        With Range("A1", "E" & lngLastRow)
            .AutoFilter
            .AutoFilter Field:=5, Criteria1:=">0"
            .Copy OKSheet.Range("A1")
            .AutoFilter Field:=5, Criteria1:="<0"
            .Copy ErrorSheet.Range("A1")
            .AutoFilter
        End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

تم وضع تعليق على السطرين المطلوبين

[عزيز عرابي]

شكرا جزيلاً أخي ياسر خليل أبو البراء