Optimisation d'une boucle

[Cocoi]

Bonjour tout le monde,

Je suis confronté à un problème d'optimisation ayant trait à des boucles. Pour l'instant ma macro marche mais c'est très très long.
Le principe est le suivant: j'ai une liste A que l'on me soumet et je souhaite comparer avec une liste B que j'ai moi-même établi. Si un élément de la liste A correspond à un de liste B, je mets l'élement liste A en rouge et y ajoute un "-L" à la fin. Si qqun peut m'aider à optimiser le code suivant, je lui en serai très reconnaissant. Merci d'avance.

Sub LEASERS()

Dim V_CELLULE_COMPAGNIE As String, V_CELLULE_REGION, i As Long

For i = 4 To 450
    'pour figer l'écran
    Application.ScreenUpdating = False
    'Activer la feuille Orders
    Sheets("Synthese").Select
    'Sélectionner la cellule Bx (ici B4)
    V_CELLULE_COMPAGNIE = "B" & i
    Range(V_CELLULE_COMPAGNIE).Select
    
    'Condition pour sortir la boucle FOR NEXT (ici : si la cellule est vide)
    If Trim(ActiveCell.Text) = "" Then
        Exit Sub
    Else
        'Appeler une fonction pour chercher dans la feuille Leasers : si la valeur retounée est true, c'est à dire "trouvé"
        If COMPARER_LEASERS(ActiveCell.Text) = True Then
            'Activer la feuille Orders
            Sheets("Synthese").Select
            Range(V_CELLULE_COMPAGNIE).Select
            Selection.Font.ColorIndex = 3
            
            'Ajouter un -l à la fin de région
         
           V_CELLULE_REGION = "D" & i
           Range(V_CELLULE_REGION).Select
           ActiveCell.FormulaR1C1 = ActiveCell.Text & "-l"
        End If
    End If
Next
   
Application.ScreenUpdating = True

'Afficher une message

Sheets("Process").Select
Range("A1").Activate
MsgBox "Leasers Boeing tries", vbOKOnly, "Leasers Boeing"
End Sub

Function COMPARER_LEASERS(V_CONTENU As String) As Boolean

Sheets("Leasers").Select

Dim V_CELLULE As String, i As Integer

For i = 2 To 500
    Application.ScreenUpdating = False
    V_CELLULE = "A" & i
    Range(V_CELLULE).Select
    If ActiveCell.Text = "" Then
    Exit Function
    Else
    
    If ActiveCell.Text = V_CONTENU Then
        COMPARER_LEASERS = True
        Exit For
    Else
        COMPARER_LEASERS = False
    End If
    End If
Next
End Function

 

[bof]

Re : Optimisation d'une boucle

bonjour,
tu peux peut-être essayer ça :

Sub test()
Dim i%, j%, k%, Tablo(), Tablo2()
Sheets("Synthese").Activate
k = Range("B2").End(4).Row
Tablo() = Range("B2:B" & k)
Sheets("Leasers").Activate
i = Range("A2").End(4).Row
Tablo2() = Range("A2:A" & i)
For i = 1 To UBound(Tablo())
For j = 1 To UBound(Tablo2())
If Tablo(i, 1) = Tablo2(j, 1) Then
Sheets("Synthese").Range("A" & i + 1).Font.ColorIndex = 3
Sheets("Synthese").Range("D" & i + 1) = Sheets("Synthese").Range("D" & i + 1) & "-1"
End If
Next
Next
End Sub

C'est surement perfectible, mébon...
A+

 

[Robert]

Re : Optimisation d'une boucle

Bonjour le fil, bonjour le forum,

Autre proposition :

Dim cel As Range 'déclare la variable cel
 
'pour figer l'écran
Application.ScreenUpdating = False
 
For Each cel In Sheets("Synthese").Range("B4:B450") 'boucle sur toutes les cellules cel de la plage B4:B450
    If cel.Value <> "" Then 'condition 1 : si la cellule n'est pas vide
        If COMPARER_LEASERS(cel.Value) = True Then 'condition 2 : si la fonction est vérifiée
            cel.Font.ColorIndex = 3 'colore le texte en rouge
            cel.Value = cel.Value & "-l" 'rajoute "-l" au texte
            'ou cel.Offset(0,1).Value = Cel.Value & "-1") j'ai pas bien compris...
            End If 'fin de la condition 2
    End If 'fin de la condition 1
Next cel 'prochaine cellule de la plage
 
Application.ScreenUpdating = True 'affiche les changements à l'écran

 

[Cocoi]

Re : Optimisation d'une boucle

Merci pour vos réponses.

Robert merci encore je gagne 5 minutes sur 25, vraiment super.

Comme j'ai 5 procédures sur des critères différents, je pense que je vais pouvoir rendre le traitement du classeur entier supportable!

 

[bof]

Re : Optimisation d'une boucle

bonsoir,
et moi je gagne quoi ? 😀
(Si mon truc fonctionne correctement)
A+

 

[PMO2]

Re : Optimisation d'une boucle

Bonjour,

Voici la méthode Lucky Luke (qui tire plus vite que son ombre).

Copiez le code suivant dans un module standard

Sub Leasers_pmo()
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim var1
Dim var2
Dim i&
Dim j&
Dim tempo1
Dim tempo2
Set S = Sheets("Leasers")   'Nom de la feuille à adapter
Set R = S.Range("a1:a500")
var2 = R
Set S = Sheets("Synthese")  'Nom de la feuille à adapter
Set R = S.Range("a1:d450")
var1 = R
For i& = 4 To 450
  tempo1 = Trim(var1(i&, 2))
  If tempo1 <> "" Then
    For j& = 2 To 500
      tempo2 = Trim(var2(j&, 1))
      If tempo2 <> "" Then
        If tempo1 = tempo2 Then
          If R2 Is Nothing Then
            Set R2 = Range(Cells(i&, 2), Cells(i&, 2))
          Else
            Set R2 = Application.Union(R2, Range(Cells(i&, 2), Cells(i&, 2)))
          End If
          var1(i&, 4) = CStr(var1(i&, 4)) & "-L"
          Exit For
        End If
      End If
    Next j&
  End If
Next i&
If R2 Is Nothing Then Exit Sub
S.Activate
R = var1
S.Range(R2.Address).Font.ColorIndex = 3
End Sub

Sur ma machine, j'obtiens le résultat en moins d'une seconde.

Cordialement.

PMO
Patrick Morange