Affecter une valeur avec deux critères de comparaison

Question

ZBonjour, 

Cela fait plusieurs heures que je suis sur un petit problème et j'ai vraiment besoin de vous.

Sur une feuille excel j'ai deux tableaux :
- Dans le tableau 1 j'ai 7 colonnes (d'A à F) mais la 7e colonne ne dispose d'aucune valeur.
- Dans le tableau 2 j'ai 7 colonnes (de I à O) mais sur celui-là la 7e colonne contient des valeurs.

De plus le tableau 1 à prés de 8500 lignes de données, alors le tableau 2 n'en contient que 250 environ.

Mon objectif serait de parcourir tous le tableau (tab 1 ou 2) afin de comparer la colonne B et C avec celle de l'autre tableau J et K. 

Si les données de Bx et Cx sont pareilles que Jy et Ky, on copie la donnée de la colonne Oy dans Fx.

J'ai déjà réalisé un code VBA qui marche mais uniquement pour 200-500 lignes. Au delas de cette valeur le traitement est trop long et n'aboutit pas.


Code VBA :

Sub Analyse()
    Dim cmpa As Integer
    Dim cmpb As Integer
    Dim Dern As Long
    
    Dern = Range("A" & Rows.Count).End(xlUp).Row 'passez le curseur sur dernièreLigne pour en lire la valeur
    
    Application.ScreenUpdating = False
    
    For cmpa = 2 To 500
    For cmpb = 2 To 500
        If Range("J" & cmpa) = Range("B" & cmpb) And Range("K" & cmpa) = Range("C" & cmpb) Then
        Worksheets(1).Range("F" & cmpa).Value = Worksheets(1).Range("N" & cmpb).Value
        End If
        Next cmpb
    Next cmpa
 
    MsgBox "Analyse terminé !"
    Application.ScreenUpdating = True
End Sub

Je voudrais donc avoir de l'aide pour optimiser, modifier mon code ou bien m'aider à trouver une solution afin d'utiliser un autre algorithme plus efficace pour se problème.

Je vous remercie déjà par avance pour votre aide.
      EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles  ICI 

Merci d'y penser dans tes prochains messages.
Configuration: Windows 7 / Chrome 43.0.2357.134

Kuartz · Answer

Bonjour,

"Trop longue et n'aboutit pas"? Ca me paraît étrange...

Est-ce que la ligne de code :

Dern = Range("A" & Rows.Count).End(xlUp).Row 'passez le curseur sur dernièreLigne pour en lire la valeur 

Ne serait pas erronée? En effet, est ce que vos tableaux ont le même nombre de ligne?

De plus, où avez vous utilisé la variable Dern?

Vous auriez dû écrire :

For cmpa = 2 To Dern 
For cmpb = 2 To Dern

Je vous propose un autre code :

Sub Analyse() 
Dim cmpa As Integer 
Dim cmpb As Integer 
Dim Dern1 As Long
Dim Dern2 As Long

Dern1 = Cells(Application.Rows.Count, 1).End(xlUp).Row
Dern2 = Cells(Application.Rows.Count, 15).End(xlUp).Row

Application.ScreenUpdating = False

For cmpa = 2 To Dern2 
For cmpb = 2 To Dern1

If Range("J" & cmpa) = Range("B" & cmpb) And Range("K" & cmpa) = Range("C" & cmpb) Then 
Range("F" & cmpa).Value = Range("N" & cmpb).Value 
End If 
Next cmpb 
Next cmpa

MsgBox "Analyse terminé !"

End Sub 

Cordialement.

Edit : Pardon, je n'avais pas vu que vous aviez répondu à la question : Vos tableaux ont-ils le même nombre de lignes...

michel_m · Answer

Bonjour,

peux tu avoir des doublons dans la concaténation de 2 colonnes
style B & C  tableau 1 et J & K ? tableau 2 ?

au besoin
Mettre un extrait du classeur (2000 lignes env.) sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci  proposé (clic droit) dans le message de réponse
Dans l'attente

michel_m · Answer

le traitement est trop long et n'aboutit pas 

150 lignes dans colonnes JK et 2000 en colonnes BC  traitées en 0,06 secondes, ça t'irait ?

Option ExplicitOption Base 1'----------Sub affecter_colO_si()Dim Derlig As Integer, T_tamponDim Cptr As Integer, T_colbc(), T_colfDim Dico As Object, T_coljk, T_colo, Ref As StringDim Start As Single'-----------------------initialisation- mémorisation cellules En RAM    Start = Timer    Application.ScreenUpdating = False    'nettoyage col F    Range("F2:F10000").ClearContents    'mémorisation tableaux BC et F        Derlig = Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row        T_tampon = Range("B2:C" & Derlig)                'concaténation des colonnes B & C        ReDim T_colbc(Derlig - 1)        For Cptr = 1 To UBound(T_tampon)        T_colbc(Cptr) = T_tampon(Cptr, 1) & " " & T_tampon(Cptr, 2)        Next         Set T_tampon = Nothing        'mémorisation colonne F        T_colf = Application.Transpose(Range("F2:F" & Derlig))    'mémorisation tableaux JK et O        Derlig = Columns("J").Find(what:="*", searchdirection:=xlPrevious).Row        T_coljk = Range("J2:K" & Derlig)        T_colo = Application.Transpose(Range("O2:O" & Derlig))    'Creation d'un couple JK concaténées et position dans taleau col O        Set Dico = CreateObject("scripting.dictionary")        For Cptr = 1 To UBound(T_coljk)            Ref = T_coljk(Cptr, 1) & " " & T_coljk(Cptr, 2)            If Not Dico.exists(Ref) Then                Dico.Add Ref, T_colo(Cptr)            End If        Next        '---------------------Recherche des égalités colBC et dico et affectation de O dans F    For Cptr = 1 To UBound(T_colbc)        Ref = T_colbc(Cptr)        If Dico.exists(Ref) Then: T_colf(Cptr) = Dico.Item(Ref)        Next'---------------------------restitution    Range("F2").Resize(UBound(T_colf), 1) = Application.Transpose(T_colf)' essai de durée à supprimer après essais    Application.ScreenUpdating = True     MsgBox "recherche effectuée en: " & Timer - Start & " sec."End Sub

ci joint la maquette à étudier à la maison ce soir plutôt que de regarder bêtement le match de foot :o)
http://www.cjoint.com/c/EJinbLZYxFk


 Michel

Affecter une valeur avec deux critères de comparaison

3 réponses

Discussions similaires

Newsletters