Option Explicit
 
Sub ExcelDiet()
 
 Dim j As Long
 Dim k As Long
 Dim LastRow As Long
 Dim LastCol As Long
 Dim ColFormula As Range
 Dim RowFormula As Range
 Dim ColValue As Range
 Dim RowValue As Range
 Dim Shp As Shape
 Dim ws As Worksheet
 
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
 On Error Resume Next
 
 For Each ws In Worksheets
 With ws
 ' Tìm ô sử dụng cuối cùng với công thức và giá trị
 ' Tìm theo cột và hàng
 On Error Resume Next
 Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
 LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
 Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
 LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
 Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
 LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
 Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
 LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
 On Error Goto 0
 
 ' Xác định cột cuối cùng
 If ColFormula Is Nothing Then
 LastCol = 0
 Else
 LastCol = ColFormula.Column
 End If
 If Not ColValue Is Nothing Then
 LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
 End If
 
 ' Xác định hàng cuối
 If RowFormula Is Nothing Then
 LastRow = 0
 Else
 LastRow = RowFormula.Row
 End If
 If Not RowValue Is Nothing Then
 LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
 End If
 
 ' Xác định xem có shapes nào nằm ngoài hàng cuối và cột cuối
 For Each Shp In .Shapes
 j = 0
 k = 0
 On Error Resume Next
 j = Shp.TopLeftCell.Row
 k = Shp.TopLeftCell.Column
 On Error Goto 0
 If j > 0 And k > 0 Then
 Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
 j = j + 1
 Loop
 If j > LastRow Then
 LastRow = j
 End If
 Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
 k = k + 1
 Loop
 If k > LastCol Then
 LastCol = k
 End If
 End If
 Next
 
 .Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete
 .Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete
 End With
 Next
 
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 
End Sub