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

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

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



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

Sub Test_DeleteAllExceptPrintArea()
    Dim strRange        As String
    Dim ws              As Worksheet

    Application.ScreenUpdating = False
        For Each ws In ThisWorkbook.Worksheets
            strRange = CStr(ws.PageSetup.PrintArea)
            DeleteAllExceptPrintArea ws.Range(strRange)
        Next ws
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

Sub DeleteAllExceptPrintArea(rngToKeep As Range)
    Dim ws          As Worksheet
    Dim bl          As Boolean
    Dim rngRow      As Range
    Dim rngCol      As Range
    Dim rowDelete   As Range
    Dim colDelete   As Range
    Dim iRow        As Long
    Dim iCol        As Long
    Dim i           As Long

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

    Set rngRow = Nothing
    Set rngCol = Nothing
    Set rowDelete = Nothing
    Set colDelete = Nothing
    Set ws = Nothing
End Sub

رابط الملف من هنا

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