Delete Any data not on print area

[Prani]

Hi

Can anyone recommend any macros for deleting any data not on the print area.

Thanks so much

 

[BrianMH]

There is probably a more efficient way of doing this but this should work.

Sub caller()
'edit the sheet you want to do this for
Call DeleteOutsideOfPrintArea(Sheets("sheet1"))


End Sub


Sub DeleteOutsideOfPrintArea(WS As Worksheet)
Dim c As Range
For Each c In NonEmptyCells(WS.Cells).Cells
    If Not Intersect(c, WS.Range(WS.PageSetup.PrintArea)) Then
        c.ClearContents
    End If
Next


End Sub






Function NonEmptyCells(TestRange As Range) As Range
    Dim r1 As Range
    Dim r2 As Range
    If Not TestRange.Cells.Count > 1 Then
        Set NonEmptyCells = TestRange
        Exit Function
    End If
    On Error Resume Next
    Set r1 = TestRange.SpecialCells(xlCellTypeFormulas)
    Set r2 = TestRange.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If r1 Is Nothing And Not r2 Is Nothing Then
        Set NonEmptyCells = r2
    ElseIf r2 Is Nothing And Not r1 Is Nothing Then
        Set NonEmptyCells = r1
    ElseIf r2 Is Nothing And r1 Is Nothing Then
        Set NonEmptyCells = TestRange.Cells(1, 1)
    Else
        Set NonEmptyCells = Union(r1, r2)
    End If


End Function

 

[Prani]

Thanks Brian

How do I apply this to the entire workbook?

 

[BrianMH]

Call it with this code. It loops through all the worksheets and calls the sub.

'run this to clear all worksheets
Sub WorkbookClearOutsidePrint()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    DeleteOutsideOfPrintArea ws
Next




End Sub


Sub DeleteOutsideOfPrintArea(ws As Worksheet)
Dim c As Range
For Each c In NonEmptyCells(ws.Cells).Cells
    If Intersect(c, ws.Range(ws.PageSetup.PrintArea)) Is Nothing Then
        c.ClearContents
    End If
Next




End Sub




Function NonEmptyCells(TestRange As Range) As Range
    Dim r1 As Range
    Dim r2 As Range
    Dim dCellCount As Double
    If Int(Application.Version) >= 12 Then
        dCellCount = TestRange.Cells.CountLarge
    Else
        dCellCount = TestRange.Cells.Count
    End If
    If Not TestRange.Cells.CountLarge > 1 Then
        Set NonEmptyCells = TestRange
        Exit Function
    End If
    On Error Resume Next
    Set r1 = TestRange.SpecialCells(xlCellTypeFormulas)
    Set r2 = TestRange.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If r1 Is Nothing And Not r2 Is Nothing Then
        Set NonEmptyCells = r2
    ElseIf r2 Is Nothing And Not r1 Is Nothing Then
        Set NonEmptyCells = r1
    ElseIf r2 Is Nothing And r1 Is Nothing Then
        Set NonEmptyCells = TestRange.Cells(1, 1)
    Else
        Set NonEmptyCells = Union(r1, r2)
    End If




End Function