Sub ClearExcessRowsAndColumns()
Dim ar As Range, r As Double, c As Double, tr As Double, tc As Double
Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
Dim shp As Shape
Dim wbSource As Workbook
    fname = Application.GetOpenFilename( _
            FileFilter:="Excel檔(*.xls),*.txt", _
            Title:="請選取要減肥的檔案", MultiSelect:=False)
    '判斷使用者是否有選取檔案，或按取消
    If VarType(LogFileName) = vbBoolean Then
        Exit Sub
    End If
    Set wbSource = Application.Workbooks.Open(CStr(fname))
    fkb = FileLen(wbSource.FullName) / 1024
    On Error Resume Next
    For Each wksWks In wbSource.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 & _
                    "' 工作表有密碼保護無法檢查." _
                    , vbInformation
        Else
            Application.StatusBar = "檢查 " & wksWks.Name & ", 請稍候..."
            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
                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 = "清理 " & _
                        wksWks.Name & ", 工作表上多餘的格式，請稍候..."
                Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count)
                ur.Clear
                ur.EntireRow.RowHeight = _
                        wksWks.StandardHeight
                Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
                        wksWks.Cells(1, 256)).EntireColumn
                ur.EntireColumn.ColumnWidth = _
                        wksWks.StandardWidth
            End If
        End If
        'Reset protection.
        wksWks.Protect "", blProtDO, blProtCont, blProtScen
        Err.Clear
    Next
    DoEvents
    wbSource.Save
    lkb = FileLen(wbSource.FullName) / 1024
    MsgBox "'" & wbSource.Name & _
            "' 已減肥成功" & fkb - lkb & "KB", vbInformation
    wbSource.Close SaveChanges:=True
    Application.StatusBar = False
End Sub