Optimisation de macro existante

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.

Code:

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

Cliquez pour agrandir...

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

Ardamire