Problème de boucle vba

Version imprimable

18/02/2011, 16h00
skipeemed

Problème de boucle vba

Bonjour,

Je veux faire une boucle qui me donnera comme résultat pour chaque cellule différente la cellule qui as le plus grand score ou de la première si le score est le même ou de la cellule elle même si le score est unique. Par exemple si j'ai le tableau suivant:

Nom prénom score
AAAA BBBBBB 123
AAAA BBBBBB 456
CCCC DDDDD 444
CCCC DDDDD 444
EEEE FFFFF 1567

Comme cela, je pourrai avoir comme résultat:
AAAA BBBBBB 456
CCCC DDDDD 444
EEEE FFFFF 1567

Voilà je veux une boucle qui ne prenne en compte que ces lignes, pour que je puisse les ajouter dans un formulaire.

Cdt,
SKIP
18/02/2011, 16h41
ZebreLoup

Le mieux est sans doute de mettre les données dans un tableau, puis de les trier (tu trouveras des tonnes d'algorithme de tri sur le web), et enfin de faire une passe pour éliminer les doublons.
18/02/2011, 17h55
skipeemed

Bonjour,

Normalement moi ce dont j'ai besoin, c'est que la boucle me prenne les lignes dont j'ai besoin et les insérer dans un formulaire dans le web.

Il y' aurai pas un code qui me sélectionne les bonnes lignes.
Moi j'ai le code pour la saisie dans le formulaire web, mais ce qui me manque c'est le choix des bonnes lignes.

Moi en attendant, ce que je fais c'est que je mets le code :

Code:

const i = numéro_ligne

et j'applique la macro pour chaque ligne dont j'ai besoin, donc ça me prend du temps.

Voilà
Cdt,
SKIP

Bonjour

en attendant peut-^tre mieux

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub dire_zebest()
Dim Lig As Long
Dim dico As Object
Dim Ref As String, cptr As Long
Dim T_item, T_key, T_tampon, T_out
 
Set dico = CreateObject("scripting.dictionary")
Lig = Cells(Cells.Rows.Count, 1).End(xlUp).Row
 
For cptr = 2 To Lig
    Ref = Cells(cptr, 1) & ";" & Cells(cptr, 2)
    If Not dico.exists(Ref) Then
        dico.Add Ref, Cells(cptr, 3)
    End If
Next
 
For cptr = 2 To Lig
    Ref = Cells(cptr, 1) & ";" & Cells(cptr, 2)
    If dico.exists(Ref) Then
        If dico(Ref) < Cells(cptr, 3) Then
            dico(Ref) = Cells(cptr, 3).Value
        End If
     End If
Next
T_item = dico.items
T_key = dico.keys
 
ReDim T_out(UBound(T_key), 1)
For cptr = 0 To UBound(T_key)
    T_tampon = Split(T_key(cptr), ";")
    T_out(cptr, 0) = T_tampon(0)
    T_out(cptr, 1) = T_tampon(1)
Next
 
Range("F2").Resize(dico.Count, 2) = T_out
Range("H2").Resize(dico.Count, 1) = Application.Transpose(T_item)
 
End Sub

Sans mettre tous les détails, tu peux faire ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
L = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Sort de ligne 1 à ligne L key1:= nom key2:= prénom key3:=score
L1 =1
Col1 = 20   ' pour mettre la liste finale dans la colonne 20
(nom & prenom de la ligne L1) = (nom & prenom de la ligne 1)
(score ligne L1) = (score ligne 1)
 
 
for i = 1 to L
   if (nom& prenom de la ligne i) = (nom & prenom de la ligne L1) then
         if (score ligne i) > (nom & prenom de la ligne L1) then
             (score ligne L1) = (score ligne i)
         end if
    else
         L1 = L1 + 1
         (nom & prenom de la ligne L1) = (nom & prenom de la ligne i)
         (score ligne L1) = (score ligne i)           
   end if
Next

C'est compréhensible?

Salut
Par rapport au code de Michel_M, pourquoi avoir fait deux boucle au départ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
For cptr = 2 To Lig
    ref = Cells(cptr, 1) & ";" & Cells(cptr, 2)
    If Not dico.exists(ref) Then
        'Si le joueur n'existe pas, on rajoute son profile
        dico.Add ref, Cells(cptr, 3)
    Else
        'Si le joueur a déjà un profil, on met celui ci a jour si le score obtenu est plus élevé que le précédent
        If dico(ref) < Cells(cptr, "C") Then dico(ref) = Cells(cptr, "C")
    End If
Next
 
'For cptr = 2 To Lig
'    ref = Cells(cptr, 1) & ";" & Cells(cptr, 2)
'    If dico.exists(ref) Then
'        If dico(ref) < Cells(cptr, 3) Then
'            dico(ref) = Cells(cptr, 3).Value
'        End If
'     End If
'Next

Autant tout faire lors de la première boucle, non?

++
Qwaz

20/02/2011, 18h21
Michel_M

Tout à fait, Bien vu!:ccool:
Merci