معرفة كود تحديد نطاق استناداً إلى محتوى خلية

[thapet422]

ممكن كود فيسول باسيك الذي يفرز قيم العمود K تنازليا ومن ثم تحديد النطاق K1:A واخر صف يكون عند اخر خلية في العمود K تكون قيمتها اكبر من 0.3 من ثم قص النطاق ولصقة في ورقة اخرى مع عمل كافة الحدود لخلايا النطاق 

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

 

 

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

أخي الحبيب ارفق ملف للإطلاع عليه

قم بضغط الملف أولاً ثم قم برفعه

تقبل تحياتي

[thapet422]

شكرا لاهتمامكم

اليكم الملف المرفق الخاص بطلب المساعدة المقدم مسبقا

نموذج تحويل.rar

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

أخي الفاضل يرجى تغيير اسمك للغة العربية

إليك الملف التالي وإن شاء الله يفي بالغرض

Sub YasserKhalil()
        Dim I As Long, LastRow As Long
        Application.ScreenUpdating = False
            Sheet1.Copy After:=Sheets(Sheets.Count)
            Sheets("Sheet1 (2)").Name = "Temp"
        
            With Sheets("Temp")
                LastRow = .Cells(Rows.Count, 4).End(3).Row
                .Range("A1:D" & .Cells(Rows.Count, 1).End(3).Row).Sort Key1:=.Range("D1:D" & .Cells(Rows.Count, 1).End(3).Row), Order1:=xlDescending, Header:=xlYes
                .AutoFilterMode = False
                .Range("A1:D1").AutoFilter
                .Range("A1:D1").AutoFilter Field:=4, Criteria1:=">0.3", Operator:=xlOr, Criteria2:="CVErr(xlErrRef)"
                For I = LastRow To 1 Step -1
                    If Rows(I).EntireRow.Hidden = True Then Rows(I).EntireRow.Delete
                Next I
                .Cells.AutoFilter
                .Shapes("Button 1").Delete
            End With
        Application.ScreenUpdating = True
End Sub

الكود ينفذ مرة واحدة ... وإن شاء الله يؤدي الغرض

Copy Sheet & AutoFilter With Criteria & Delete Hidden Rows.rar

[thapet422]

يعطيك العافية اخي ياسر 

حاولت اغير اسم للعربية لكن في اسماء نفس الاسم ولم يتيح لي ذلك طبعا ( اسمي ثابت حدير)

في طلب اضافي استاذ ياسر

يا ليت لو تشرح لي الكود الذي قدمت لانني محتاج اطبقه في عدة مواضع مع تغيير في الاسماء وموا ضع الاعمدة 

مع التوضيح لوكانت ورقة "temp " موجودة بشكل رسمي ضمن المصنف باسم النتيجة

 

وان شاء الله ربنا يحفظك ويرزقك من اوسع ابوابه ويجعل هذا العمل في ميزان حسناتك

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