Microsoft 365 Optimisation boucle

[doudel]

Bonjour,
J'ai mis en place deux boucles dans une procédure VBA afin de faire le tri d'une feuille Excel et copier les lignes triées vers une autre feuille. Ces deux boucles fonctionnent mais s'exécutent deux fois de suite. Je pense avoir mal organisé mes instructions mais je ne parviens pas à trouver.

Private Sub TxtBoxSerie_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If Me.TxtBoxSerie <> "" Then

'''''''''''''''''''''''''''''''''''
'Liste déroulante 1
'''''''''''''''''''''''''''''''''''

'Déclarartion des variables
Dim Serie As Range
Dim listeSerie As Range
Dim NbLignes As Long
Dim LigneActive As Long

'Affectation des variables
Set listeSerie = Feuil12.Range("A2", Feuil12.Range("A1").End(xlDown))
NbLignes = listeSerie.Rows.Count
LigneActive = 0

'Choix de la feuille a modifier
Sheets("TRI_SERIE").Activate
'On efface le contenu des cellules
Range("A2:AM500").ClearContents
Range("A1").Select

'Sheets.Add
Feuil12.Range("A1").EntireRow.Copy ActiveCell
Range("A2").Select

'On boucle chaque série se trouvant dans la liste
For Each Serie In listeSerie
    
    'On se décale d'une ligne vers le bas
    LigneActive = LigneActive + 1
    
    'On recherche la sous parcelle qui été saisie dans la liste déroulante
    If Serie.Offset(0, 2).Value = Me.TxtBoxMassif.Value Then
        ' Si la sous parcelle est trouvée on va récupérer l'enregistrement de la ligne
        Serie.EntireRow.Copy ActiveCell
        ActiveCell.Offset(1, 0).Select
                
        End If
        
        Me.ProgressBar1.Value = (LigneActive / NbLignes) * 100

Next Serie

On Error GoTo 1
    

'''''''''''''''''''''''''''''''''''
'Liste déroulante 2
'''''''''''''''''''''''''''''''''''

'Déclaration des variables
Dim Region As Range
Dim listeRegion As Range
'Dim NbLignes As Long
'Dim LigneActive As Long

'Affectation des variables
Set listeRegion = Feuil13.Range("A2", Feuil13.Range("A1").End(xlDown))
NbLignes = listeRegion.Rows.Count
LigneActive = 0

'On insére une nouvelle feuille
Sheets("TRI_ORIGINE_REGION").Activate
'On efface le contenu des cellules
Range("A2:D200").ClearContents
Range("A1").Select

'Choix de la feuille a modifier
Feuil13.Range("A1").EntireRow.Copy ActiveCell
Range("A2").Select

'On boucle chaque région se trouvant dans la liste
For Each Region In listeRegion
    
    'On se décale d'une ligne vers le bas
    LigneActive = LigneActive + 1
    
    'On recherche la région qui été saisie dans la liste déroulante
    If Region.Offset(0, 0).Value = Me.TxtBoxRegion.Value Then
        ' Si la région est trouvée on va récupérer l'enregistrement de la ligne
        Region.EntireRow.Copy ActiveCell
        ActiveCell.Offset(1, 0).Select
        
      End If
        
          Me.ProgressBar1.Value = (LigneActive / NbLignes) * 100

Next Region

End If

End Sub

Merci

 

[cathodique]

Bonsoir,

Voir ici point 2.5

Bonne soirée.

 

[Wayki]

Bonsoir,
On a une gestion d'erreur qui renvoie vers l'instruction 1, hors je ne vois pas d'instruction 1 dans la procédure.
Merci de faire un passage dans les règles du forum, vous obtiendrez plus d'aide en lisant attentivement ce qui y est mentionné.
A +