[VBA]Performance - Suppression Lignes & Colonnes

[STephane]

bonjour,

Je réécris pour une énième fois une suppression de lignes et colonnes (inspiration chez ozgrid.com). La macro très lente chez moi malgré une dimension raisonnable de mon tableau (200 lignes * 30 colonnes).

Qu'est-ce que cela donne chez vous ?

Sub test()
Dim Tgt As Range
Dim Rw As Range

'Poursuite du programme en cas d'erreur
On Error Resume Next

'Effacement des premières lignes de l'extraction
'[1:3,5:5].EntireRow.Delete

'Sélection de la plage utilisée
ActiveSheet.UsedRange.Select

'Sortie de programme si aucune donnée n'est présente
If WorksheetFunction.CountA(Selection) = 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)
Selection.Replace What:=" ", Replacement:="", LookAt:=xlWhole

'Effacer les lignes vides ou les colonnes avec une seule valeur
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    
    'sélection des cellules vides de la plage précédemment sélectionnée
    Selection.SpecialCells(xlCellTypeBlanks).Select
    
    'Suppression des lignes vides en bouclant sur les lignes de la sélection
    For Each Rw In Selection.Rows
        If WorksheetFunction.CountA(Rw.EntireRow) = 0 Then Rw.EntireRow.Delete
    Next Rw
    
    'suppression des colonnes vides et des champs pour lesquels il n'y a pas de valeur
    For Each Rw In Selection.Columns
     If WorksheetFunction.CountA(Rw.EntireColumn) <= 1 Then Rw.EntireColumn.Delete
    Next Rw
    
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub

je pense que c'est mon système , j'ai le même problème avec la petite macro ci-dessous.

Sub dhdhdhd()
DoEvents
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub

 

[Guest]

Re : [VBA]Performance - Suppression Lignes & Colonnes

Bonjour Stéphane,

Pour la première macro, essaie ceci:

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

Et Pour la deuxième:

Sub DeleteShapes()
    With ActiveSheet
        Do While .Shapes.Count > 0
            .Shapes(1).Delete
        Loop
    End With
End Sub

A+

 

[STephane]

Re : [VBA]Performance - Suppression Lignes & Colonnes

Super, comme je l'évoquai, sujet souvent refait, même ta macro me rappelle quelquechose ;-) je pense avoir fait ou trouvé un truc comme ça. Je vais tester de suite.

...
J'ai fait une comparaison approximative avec la macro ci-dessous.

Sub comparaison_temps()
Dim dd
dd = Time: Sheets("1").Select: Call test_xld_1: MsgBox (Format((Time - dd), "HH:MM:SS"))
dd = Time: Sheets("2").Select: Call test_xld_2: MsgBox (Format((Time - dd), "HH:MM:SS"))
End Sub

Test de la petite macro de suppression des formes : super rapide !
=> ADOPTEE

Test de la macro de suppression des lignes et colonnes
-> elles sont aussi rapides l'une que l'autre à priori
-> je viens de constater que les 816 shapes (invisibles à l'oeil nu) sur ma feuille de test pénalisaient énormémént la macro !
-> la tienne est toutefois plus juste ;-) la mienne loupe quelques lignes
=> ADOPTEE aussi.

Merci Hasco

 

[Guest]

Re : [VBA]Performance - Suppression Lignes & Colonnes

Re,

Sur combien de lignes as-tu testé la macro de suppression lignes/colonnes.

La différence ce verra là.

A+

 

[STephane]

Re : [VBA]Performance - Suppression Lignes & Colonnes

300 pas plus.
tu as raison.

bonne soirée