Traitement par macro devenu trop long

Question

Voilà plusieurs années que je n'avais pas utilisé les macro excel. Mais je m'y remets depuis 1 mois. J'ai une macro qui traite mes données et les replace dans 1 onglet pour chaque valeur définie. Mon problème est qu'aujourd'hui, la taille d'entrée de mes fichiers de données est énorme, (180000 lignes) et que le traitement prend 4H. Le nombre de données a reclasser augmente aussi régulièrement (156 aujourd'hui). Ces données sont prisent par un pc qui pilote une baie de surveillance d'un appareil de controle. Y aurait-il une possibilité d'améliorer mon traitement ? je pense que mon copier/coller de chaque ligne doit pouvoir être amélioré, mais je ne trouve pas de solution plus rapide. Voici une partie de ma macro (je n'ai laissé que 5 mots clé, mais j'en ai 156 traité sous la même forme): Dim MotCle Dim i As Byte Dim C As Range Dim F As String MotCle = Array("TECUDATA_A3", "TECUDATA_B3", "TCDATA01_A3", "TCDATA02_A3", "TCDATA03_A3") 'liste des mots à classer For i = 1 To 156 Sheets.Add After:=Sheets(Sheets.Count) ' création des onglets Next i Sheets("Feuil1").Select For i = 0 To UBound(MotCle) Do Set C = Worksheets("Feuil1").Columns(4).Find(MotCle(i), LookIn:=xlValues, LookAt:=xlPart) 'Si le mot clé est trouvé If Not C Is Nothing Then 'On définit le nom de la feuille où sera effectuée la copie F = "Feuil" & (i + 2) With Worksheets(F) 'On définit la ligne où sera effectué le collage Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1 'On effectue le copier / coller C.EntireRow.Copy .Range("A" & Ligne) 'On supprime la ligne dans la feuil1 C.EntireRow.Delete End With End If Loop While Not C Is Nothing Next i Si vous avez des idées, je suis prêt à essayer plein de choses. L'utilisation de VBA revient petit à petit, mais j'ai oublié pas mal de choses ces dernières années sans l'utiliser. Merci à tous pour vos coup de main. Luluke...

h2so4 · Answer

Essaie ceci Dim MotCle Dim i As Byte Dim C As Range Dim F As String Application.ScreenUpdating = False 'jusqu'à 137 x plus rapide Application.EnableEvents = False ac = Application.Calculation Application.Calculation = xlCalculationManual MotCle = Array("TECUDATA_A3", "TECUDATA_B3", "TCDATA01_A3", "TCDATA02_A3", "TCDATA03_A3") 'liste des mots à classer For i = 1 To 156 Sheets.Add After:=Sheets(Sheets.Count) ' création des onglets Next i Sheets("Feuil1").Select For i = 0 To UBound(MotCle) Do Set C = Worksheets("Feuil1").Columns(4).Find(MotCle(i), LookIn:=xlValues, LookAt:=xlPart) 'Si le mot clé est trouvé If Not C Is Nothing Then 'On définit le nom de la feuille où sera effectuée la copie F = "Feuil" &amp; (i + 2) With Worksheets(F) 'On définit la ligne où sera effectué le collage Ligne = .Range("F" &amp; Rows.Count).End(xlUp).Row + 1 'On effectue le copier / coller C.EntireRow.Copy .Range("A" &amp; Ligne) 'On supprime la ligne dans la feuil1 C.EntireRow.Delete End With End If Loop While Not C Is Nothing Next i Application.Calculation = ac Application.EnableEvents = True Application.ScreenUpdating = True...

h2so4 · Answer

La première ligne était celle qui pouvait te faire gagner le plus de temps sans modifier ta logique. les autres t'apporteront quelque chose si tu as des événements qui sont déclenchés par les opérations de ta macro ou si tu as de nombreuses formules dans tes feuilles. En modifiant la logique, on pourrait commencer par trier la feuil1 et faire des opérations par blocs, mais j'ai besoin d'un exemple pour pouvoir t'aider davantage...

h2so4 · Answer

A tester ... Sub test() Application.ScreenUpdating = False Application.EnableEvents = False ac = Application.Calculation Application.Calculation = xlCalculationManual Set ws1 = Sheets("Feuil1") ' dl = ws1.Range("D" &amp; Rows.Count).End(xlUp).Row ' dl dernière ligne de ws1 ws1.Range("A1:L" &amp; dl).Sort key1:=ws1.Range("D1"), order1:=xlAscending, Header:=xlNo ' tri sur colonne 4 dl = ws1.Range("D" &amp; Rows.Count).End(xlUp).Row ' dl dernière ligne de ws1 (les lignes blanches ont été poussées à la fin Set re = ws1.Range("A1:L" &amp; dl).Find("T", lookat:=xlPart) ' re première cellule avec données 'hypothèse qu'elle commence par un T If re Is Nothing Then MsgBox "pas trouvé de données": Exit Sub End If rup = "" ' identifiant du bloc de données en cours plc = 0 ' première ligne du bloc de données à copier For i = re.Row To dl ' on parcourt toutes les lignes de feuil1 If ws1.Cells(i, 4) &lt;&gt; rup Then ' si changement de bloc de données If plc &lt;&gt; 0 Then ' si lignes à copier ws1.Rows(plc &amp; ":" &amp; i - 1).Copy wst.Cells(1, 1) ' copie des lignes vers la feuille wst End If rup = ws1.Cells(i, 4) ' rup contient le nom du nouveau bloc de données Worksheets.Add after:=Worksheets(Worksheets.Count) ' on ajoute un feuille Set wst = Worksheets(Worksheets.Count) ' wst fait référence à cette feuille wst.Name = rup ' on renomme la feuille d'après le nom du bloc de données plc = i ' plc = première ligne du bloc de données End If Next i ws1.Rows(plc &amp; ":" &amp; i - 1).Copy wst.Cells(1, 1) 'on copie le dernier bloc de données Application.Calculation = ac Application.EnableEvents = True Application.ScreenUpdating = True End Sub...