bonjour
essaye cette macro, issude l'utilitaire XsClean de Microsoft.
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
On Error Resume Next
For Each wksWks In ActiveWorkbook.Worksheets
'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
Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
End If
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
End If
If Err.Number = 0 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
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..."
wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count).Clear 'Delete
wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count).RowHeight = _
wksWks.StandardHeight
wksWks.Range(wksWks.Cells(1, c + 1), _
wksWks.Cells(1, 256)).EntireColumn.Clear 'Delete
wksWks.Range(wksWks.Cells(1, c + 1), _
wksWks.Cells(1, 256)).EntireColumn.ColumnWidth = _
wksWks.StandardWidth
Else
Err.Clear
End If
End If
'Reset protection.
wksWks.Protect "", blProtDO, blProtCont, blProtScen
Next
Application.StatusBar = False
MsgBox "'" & ActiveWorkbook.Name & _
"' has been cleared of excess formatting." & Chr(13) & _
"You must save the file to keep the changes.", vbInformation
End Sub