Option Explicit
Sub test()
Dim Tgt As Range
Dim Rw As Range
Dim plg As Range
Dim oldCALCULATION As XlCalculation
Dim Titre As String
oldCALCULATION = Application.Calculation
'Poursuite du programme en cas d'erreur
'Effacement des premières lignes de l'extraction
'[1:3,5:5].EntireRow.Delete
'Sélection de la plage utilisée
On Error Resume Next
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Set plg = ActiveSheet.UsedRange
If plg Is Nothing Then GoTo FinTest
'Sortie de programme si aucune donnée n'est présente
If WorksheetFunction.CountA(plg) = 0 Then Exit Sub 'MsgBox "Pas de données", vbOKOnly, "OzGrid.com"
'Effacer les cellules ne contenant qu'un espace (cela arrive suite à l'extraction)
Titre = "Remplacement des chaine vide"
plg.Replace What:=" ", Replacement:="", LookAt:=xlWhole
'Effacer les lignes vides ou les colonnes avec une seule valeur
Titre = "Suppression des ligne vides"
'sélection des cellules vides de la plage précédemment sélectionnée
Set plg = plg.SpecialCells(xlCellTypeBlanks)
'Suppression des lignes vides en bouclant sur les lignes de la sélection
For Each Rw In plg.Rows
If WorksheetFunction.CountA(Rw.EntireRow) = 0 Then
If Tgt Is Nothing Then
Set Tgt = Rw(1)
Else
Set Tgt = Union(Tgt, Rw(1))
End If
End If
Next Rw
'Suppression en une seule fois de toutes les lignes
If Not Tgt Is Nothing Then Tgt.EntireRow.Delete
'Recréer la plage après suppression des lignes
Set plg = ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
Set Tgt = Nothing
Titre = "Suppression des colonne vides"
'suppression des colonnes vides et des champs pour lesquels il n'y a pas de valeur
For Each Rw In plg.Columns
If WorksheetFunction.CountA(Rw.EntireColumn) <= 1 Then
If Tgt Is Nothing Then
Set Tgt = Rw(1)
Else
Set Tgt = Union(Tgt, Rw(1))
End If
End If
Next Rw
'Suppression en une seule fois de toutes les colonne
If Not Tgt Is Nothing Then Tgt.EntireColumn.Delete
'Fin de macro
FinTest:
Application.Calculation = oldCALCULATION
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number > 0 Then MsgBox Titre & vbCrLf & _
Err.Number & ": " & Err.Description, vbExclamation, "Test"
End Sub