[non résolu] Accelerer une macro

Laosurlamontagne

XLDnaute Occasionnel
Bonjour à tous,

Afin de "nettoyer" un fichier excel avec un nombre très important de ligne (37528), j'ai créé la macro suivante qui me garde que les lignes où le chiffre "-300" est présent:

Code:
Sub extract()

Dim lig As Integer, Data As Worksheet

Set Data = ActiveSheet
Sheets.Add
ActiveSheet.Name = "export"
Data.Cells.Copy Sheets("export").Range("A1")

For lig = 8 To 37528
If Sheets("export").Range("H" & lig) <> -300 Then Rows(lig).Delete
Next lig

End Sub

La macro marche mais elle me fait un peu peur sur son temps d'exécution. J'ai deux questions à vous soumettre:

1- il y a t-il un moyen de l'accélérer en faisant plus simple?
2- Je voudrais que l'incrément "lig" s'affiche dans un Msgbox mais sans avoir à valider et je coince la dessus...

Sauriez-vous m'aider ?

Merci !
 

Dranreb

XLDnaute Barbatruc
Re : [non résolu] Accelerer une macro

Bonjour.
Essayez ça :
VB:
Sub Extract()
Dim Data As Worksheet, Result As Worksheet
Set Data = ActiveSheet
Worksheets.Add: Set Result = ActiveSheet
Result.Name = "export"
Data.Cells.Copy Result.[A1]
CelColLgnOù(Result.[A8], "H", "<>", -300).EntireRow.Delete
End Sub
Function CelColLgnOù(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
If Not IsNumeric(ColQuoi) Then ColQuoi = CelDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set CelColLgnOù = CelColCondR1C1(CelDéb, "RC" & ColQuoi & Opé & Valeur)
End Function
Function CelColCondR1C1(ByVal CelDéb As Range, CondR1C1 As String) As Range
Dim ColTrv As Range
With CelDéb.Worksheet.UsedRange
   Set CelColCondR1C1 = CelDéb.Resize(.Rows.Count + .Row - CelDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), CelColCondR1C1.EntireRow): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set CelColCondR1C1 = Intersect(ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow, CelColCondR1C1)
ColTrv.Delete xlShiftToLeft
End Function
 

Modeste geedee

XLDnaute Barbatruc
Re : [non résolu] Accelerer une macro

Bonsour®

lorsque l'on supprime des lignes (ou des colonnes) à l'aide d'une boucle
il faut commencer par l'indice maximum de la boucle !!!

:rolleyes:
une proposition pour éviter la boucle :
VB:
Sub Nettoie_H300()
Dim tbl As Range
    [A1].CurrentRegion.Select
    ' ----- adapter ici aux colonnes concernées  (H=8)
    ActiveSheet.Range("A:X").AutoFilter Field:=8, Criteria1:="<>-300", Operator:=xlAnd
    Application.DisplayAlerts = False
    Set tbl = Selection
    '----pour ne pas supprimmer les entetes
    tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Delete
    ActiveSheet.AutoFilterMode = False
    Application.DisplayAlerts = True
End Sub
 

Dranreb

XLDnaute Barbatruc
Re : [non résolu] Accelerer une macro

Par souci de modularité, j'ai encore décomposé mes petites fonctions de services pour ce genre de besoin :
VB:
Function CellsColLgnOù(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
CellsColLgnOù = Intersect(LignesOù(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)
End Function
Function LignesOù(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set LignesOù = LignesOùCondR1C1(LigneDéb, "RC" & ColQuoi & Opé & Valeur)
End Function
Function CellsColCondR1C1(ByVal CelDéb As Range, CondR1C1 As String) As Range
CellsColCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function
Function LignesOùCondR1C1(ByVal LigneDéb As Range, CondR1C1 As String) As Range
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function
Dans le programme appelant ça devient du coup simplement :
VB:
LignesOù(Result.Rows(8), "H", "<>", -300).Delete
À tester…
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 942
Membres
101 849
dernier inscrit
florentMIG