Optimisation d'une boucle

Cocoi · 9 Décembre 2009

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.

Code:

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 · 9 Décembre 2009

Re : Optimisation d'une boucle

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

Code:

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 · 9 Décembre 2009

Re : Optimisation d'une boucle

Bonjour le fil, bonjour le forum,

Autre proposition :

Code:

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 · 9 Décembre 2009

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 · 9 Décembre 2009

Re : Optimisation d'une boucle

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

PMO2 · 9 Décembre 2009

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

Code:

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

Optimisation d'une boucle

Cocoi

Guest

bof

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

Cocoi

Guest

bof

XLDnaute Occasionnel

PMO2

XLDnaute Accro

Discussions similaires

Optimisation d'une boucle

Cocoi

Guest

bof

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

Cocoi

Guest

bof

XLDnaute Occasionnel

PMO2

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency