Remove Excess Shading

Sub ClearExcessRowsAndColumns() 
    Dim ar As Range 
    Dim r As Double 
    Dim c As Double 
    Dim tr As Double 
    Dim tc As Double 
    Dim wksWks As Worksheet 
    Dim ur As Range 
    Dim arCount As Integer 
    Dim i As Integer 
    Dim blProtCont As Boolean 
    Dim blProtScen As Boolean 
    Dim blProtDO As Boolean 
    Dim shp As Shape 
    
    On Error GoTo ErrorHandler 
    
'    Application.ScreenUpdating = False
    For Each wksWks In ActiveWorkbook.Worksheets 
      Err.Clear 
      'Store worksheet protection settings and unprotect if protected.
      blProtCont = wksWks.ProtectContents 
      blProtDO = wksWks.ProtectDrawingObjects 
      blProtScen = wksWks.ProtectScenarios 
      wksWks.Unprotect "" 
      
      If Err.Number = 1004 Then 
         Err.Clear 
         MsgBox "'" & wksWks.Name & "' is protected with a password and cannot be checked.", vbInformation 
      Else 
         Application.StatusBar = "Checking " & wksWks.Name & ", Please Wait..." 
         r = 0 
         c = 0 

         'Determine if the sheet contains both formulas and constants
         Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)) 
         'If both fails, try constants only
         If Err.Number = 1004 Then 
            Err.Clear 
            Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants) 
         End If 
         'If constants fails then set it to formulas
         If Err.Number = 1004 Then 
            Err.Clear 
            Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas) 
         End If 
         'If there is still an error then the worksheet is empty
         If Err.Number <> 0 Then 
            Err.Clear 
            If wksWks.UsedRange.Address <> "$A$1" Then 
               ur.EntireRow.Delete 
            Else 
               Set ur = Nothing 
            End If 
         End If 
         'On Error GoTo 0
         If Not ur Is Nothing Then 
            arCount = ur.Areas.Count 
            'determine the last column and row that contains data or formula
            For Each ar In ur.Areas 
               i = i + 1 
               tr = ar.Range("A1").Row + ar.Rows.Count - 1 
               tc = ar.Range("A1").Column + ar.Columns.Count - 1 
               If tc > c Then c = tc 
               If tr > r Then r = tr 
           Next 
            'Determine the area covered by shapes
            'so we don't remove shading behind shapes
            For Each shp In wksWks.Shapes 
               tr = shp.BottomRightCell.Row 
               tc = shp.BottomRightCell.Column 
               If tc > c Then c = tc 
               If tr > r Then r = tr 
            Next 
            Application.StatusBar = "Clearing Excess Cells in " & wksWks.Name & ", Please Wait..." 
            Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count) 
                'Reset row height which can also cause the lastcell to be innacurate
               ur.EntireRow.RowHeight = wksWks.StandardHeight 
                ur.Clear 

            Set ur = wksWks.Columns(ColLetter(c + 1) & ":" & ColLetter(wksWks.Columns.Count)) 
                'Reset column width which can also cause the lastcell to be innacurate
                ur.EntireColumn.ColumnWidth = wksWks.StandardWidth 
                ur.Clear 
         End If 
      End If 
      'Reset protection.
      wksWks.Protect "", blProtDO, blProtCont, blProtScen 
      Err.Clear 
    Next 
    Application.StatusBar = False 
    ' Application.SendKeys "%(oe)~{TAB}~"

    Application.CommandBars.ExecuteMso "PicturesCompress" 
    Application.ScreenUpdating = True 
    Exit Sub 
ErrorHandler: 

End Sub