إجمالي مرات مشاهدة الصفحة

السبت، 23 أبريل 2016

حذف كل النطاقات ما عدا نطاق الطباعة Delete All Except Print Area

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

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

بفرض أن لديك أوراق عمل وقد قمت بتحديد نطاق للطباعة في هذه الأوراق ، والمطلوب حذف جميع النطاقات خارج نطاق الطباعة أي حذف الصفوف في النطاق المستخدم وكذلك حذف الأعمدة في النطاق المستخدم ، ويتم الإبقاء فقط على نطاق أو منطقة الطباعة Print Area.

وأخيراً إليكم الكود المستخد لتنفيذ المهمة

Sub TestRun()
    Dim strRange        As String
    Dim Sh              As Worksheet

    Application.ScreenUpdating = False
        For Each Sh In ThisWorkbook.Worksheets
            strRange = CStr(Sh.PageSetup.PrintArea)
            DeleteAllBut Sh.Range(strRange)
        Next Sh
    Application.ScreenUpdating = False

    MsgBox "Done...", 64
End Sub

Sub DeleteAllBut(rngToKeep As Range)
    Dim Ws              As Worksheet
    Dim rngRow          As Range
    Dim rngCol          As Range
    Dim iRow            As Long
    Dim iCol            As Long
    Dim rngRowDelete    As Range
    Dim rngColDelete    As Range

    Dim I As Long
    Dim FirstOne As Boolean

    Application.ScreenUpdating = False
        Set Ws = rngToKeep.Parent
    
        iRow = Ws.UsedRange.Rows.Count
        FirstOne = True
        For I = 1 To iRow
            Set rngRow = Ws.Range("1:1").Offset(I - 1, 0)
            If Intersect(rngToKeep, rngRow) Is Nothing Then
                If FirstOne Then
                    Set rngRowDelete = rngRow
                    FirstOne = False
                Else
                    Set rngRowDelete = Union(rngRow, rngRowDelete)
                End If
            End If
        Next I
        If Not rngRowDelete Is Nothing Then
            rngRowDelete.Delete
        End If
    
        iCol = Ws.UsedRange.Columns.Count
        FirstOne = True
        For I = 1 To iCol
            Set rngCol = Ws.Range("A:A").Offset(0, I - 1)
            If Intersect(rngToKeep, rngCol) Is Nothing Then
                If FirstOne Then
                    Set rngColDelete = rngCol
                    FirstOne = False
                Else
                    Set rngColDelete = Union(rngCol, rngColDelete)
                End If
            End If
        Next I
        If Not rngColDelete Is Nothing Then
            rngColDelete.Delete
        End If
    Application.ScreenUpdating = True

    Set rngRow = Nothing
    Set rngCol = Nothing
    Set rngRowDelete = Nothing
    Set rngColDelete = Nothing
    Set Ws = Nothing
End Sub

إعداد / ياسر خليل أبو البراء

هناك 5 تعليقات:

  1. السلام عليكم ورحمة الله وبركاته
    تبارك الرحمن ...وبارك بكم أخي الحبيب أبو البراء.

    ردحذف
  2. استاذ ياسر عايزين نعرف ما بعد البدائيات وما قبل الاحتراف انا الكلام ده مش فاهمه بس شغال علاكسيل من سنتين معادلات وشيتات

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

    ردحذف
  4. انت رائع انا بشتغل اكسيل ونفسى احترف فى ارجو مساعدتك او رفع فيديوهات تفيد بيها اصدقائك

    ردحذف
  5. بارك الله فيك أخي الكريم ..لي قناة على اليوتيوب وبها بعض الفيديوهات ولكني في الحقيقة أفضل التوثيق بالكتابة والشرح والصور والملفات المرفقة للتطبيق العملي ، لأن التطبيق العملي أفضل بكثير

    ردحذف