Optimisation de macro existante

[Ardamire]

Bonjour à tous,

Voici mon problème qui n'en n'est pas réellement un en fait

J'ai puisé dans différentes sources et je suis parvenu à faire une macro me sélectionnant les données que je souhaite dans une feuille Excel et à me les recopier dans une feuille temporaire pour les sauver au format .CSV.

Etant débutant, pourriez-vous m'indiquer s'il y a un moyen d'optimiser le code afin de réduire le temps de réalisation de la macro? Elle fait toujours la même boucle mais pour des valeurs différentes et je n'arrive pas à visualiser comment définir une boucle sur les valeurs.

Je n'ai mis qu'une partie du très long code mais les lignes qui suivaient étaient répétitives et uniquement les valeurs changeaient.

Sub Filter()

Application.ScreenUpdating = False

  Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
  
  Sheets("TEMP").Activate ' feuille de destination
  Cells.Clear
  Col = "B"                 ' colonne de la donnée non vide à tester
  NumLig = 0
  With Sheets("Import_Sheet")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value = "Label 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
    If .Cells(Lig, Col).Value = "Unit 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
        If .Cells(Lig, Col).Value = "250" Then
        .Cells(Lig, Col).EntireRow.Copy
        NumLig = NumLig + 1
        Cells(NumLig, 1).Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End If
  Next
  End With

ActiveSheet.SaveAs Filename:= _
"C:\250_Unit 1.csv", FileFormat:=xlCSV, CreateBackup:=False

Sheets("250_Unit 1").Activate ' feuille de destination
  Cells.Clear
  Col = "B"                 ' colonne de la donnée non vide à tester
  NumLig = 0
With Sheets("Import_Sheet")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value = "Label 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
    If .Cells(Lig, Col).Value = "Unit 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
        If .Cells(Lig, Col).Value = "300" Then
        .Cells(Lig, Col).EntireRow.Copy
        NumLig = NumLig + 1
        Cells(NumLig, 1).Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End If
  Next
  End With
ActiveSheet.SaveAs Filename:= _
"C:\300_Unit 1.csv", FileFormat:=xlCSV, CreateBackup:=False

Sheets("300_Unit 1").Activate ' feuille de destination
  Cells.Clear
  Col = "B"                 ' colonne de la donnée non vide à tester
  NumLig = 0
With Sheets("Import_Sheet")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value = "Label 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
    If .Cells(Lig, Col).Value = "Unit 1" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
        If .Cells(Lig, Col).Value = "400" Then
        .Cells(Lig, Col).EntireRow.Copy
        NumLig = NumLig + 1
        Cells(NumLig, 1).Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End If
  Next
  End With
ActiveSheet.SaveAs Filename:= _
"C:\400_Unit 1.csv", FileFormat:=xlCSV, CreateBackup:=False

Application.ScreenUpdating = True


End Sub

Merci pour votre aide et bonne après-midi.

Ardamire

 

[job75]

Re : Optimisation de macro existante

Bonjour Ardamire,

Ce que vous demandez ne passionnera pas les foules.

Sachez cependant qu'en VBA les Select et autres Activate sont généralement inutiles et à proscrire.

Ils ralentissent beaucoup les macros.

C'est un sujet rabâché sur XLD, cherchez un peu.

Edit : et les Copy/PasteSpecial sont très lents aussi.

Quand on copie des valeurs il faut utiliser un code de la forme :

plage1 = plage2.Value

plage1 et plage2 étant des tableaux de mêmes dimensions.

Là aussi nombreux exemples sur le forum.

A+

 

[Efgé]

Re : Optimisation de macro existante

Bonjour Ardamire, Job75 Comme j'ai fait quelque chose, je le poste. Le code est dans le code de la feuille "Import_Sheet" Cordialement