Etablir un classement (Excel/VBA)Résolu

Question

Bonjour,
Mon probl&#232;me est le suivant, je dois &#233;tablir un classement relatif &#224; un Cross, pour le classement g&#233;n&#233;ral pas de probl&#232;me, la fonction exel marche tr&#232;s bien.Par contre ,comme il y a plusieurs cath&#233;gories de coureurs et il faut aussi &#233;tablir le classement dans leurs cath&#233;goeries et c'est la que j'ai un probl&#232;me car la fonction Filtres automatique d'exel ne permet pas ce genre de chose.
Si quelqu'un avait une id&#233;e, elle serait la bienvenue.
      A               B
1                     EM
2                     DE
3                     EM
4                     SM

Il faudrait donc que dans A1 s'inscrive 1, en A2 1,  en A3 2, en A4 1   et ainsi de suite .
D'avance merci (Si mon explication n'est pas assez claire faite le moi savoir )

jpleroisse

galopin01 · Accepted Answer

Bonjour,
Le code suivant fait exactement le contraire : 
Tu mets les cat&#233;gories en colonne A et il te les classe en colonne B

Sub ClassementParCat()
'libre adaption d'une routine de zon par galopin
Dim Plage As Range, T
Set Plage = Range([A1], [A65536].End(xlUp))
T = ExtD(Plage.Value, 1)
If IsArray(T) Then
T = InverseTab(T, 1)
For i = 1 To UBound(T)
TLookUp (T(i, 1))
Next
Else
MsgBox "Error1"
End If
End Sub


Function ExtD(T, ColT As Byte)
'libre adaption d'une routine de zon
Dim i&, j&, k&, Tablo As New Collection, Tmp()
For i = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(i, ColT), CStr(T(i, ColT))
If Err = 0 Then
ReDim Preserve Tmp(1 To UBound(T, 2), 1 To j + 1)
For k = 1 To UBound(Tmp)
Tmp(k, j + 1) = T(i, k)
Next k
j = j + 1
End If
Next i
ExtD = IIf(j > 0, Tmp, "")
End Function


Function InvTab(T, Optional Base As Byte = 0)
'libre adaption d'une routine de zon
Dim Temp(), i&, j&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For i = LBound(T, 2) To UBound(T, 2)
For j = LBound(T) To UBound(T)
Temp(i, j) = T(j, i)
Next j
Next i
InvTab = Temp
End Function


Sub TLookUp(Z)
'libre adaption d'une routine de zon
Dim T As Range, t1$, n%, tR%
n = 1If Range("A1").Value Z Then n n + 1
Set T = Range("A1:A" & Range("A65000").End(xlUp).Row).Find(Z)
If Not T Is Nothing Then
t1 = T.Address
Do
tR = T.Row
Range("B" & tR).Value = n
n = n + 1
Set T = Range("A1:A" & Range("A65000").End(xlUp).Row).FindNext(T)
Loop While Not T Is Nothing And T.Address <> t1
End If
Range("B1").Value = 1
End Sub
A+

NHenry · Answer

Essaye :
i=1
Plage="B1"

do while (plage).offset(i,0).value<>""
     if (plage).offset(i,0).value>(plage).offset(i-1,0).value then
         'intervertir
         i=0
   end if
   i=i+1
loop

NH

jpleroisse · Answer

Merci NH
J'ai essay&#233;, mais cela ne marche pas ,je lance la macro, le sablier appara&#238;t et plus rien ne se passe , je dois faire Echap. pour arr&#234;ter.
Je vais essayer de la modifier, si de ton c&#244;t&#233; tu as une id&#233;e de la raison pour laquelle cela ne marche pas , elle sera de nouveau la bienvene.

jpleroisse

cs_CanisLupus · Answer

Salut,

Effectivement, ce n'est pas tr&#232;s clair. En tous cas pour moi.
Tu expliques ce que tu veux obtenir mais pas &#224; partir de quoi.
Comment  est agenc&#233; ton tableau d'origine ? (ou tes tableaux)

Loup Gris

galopin01 · Answer

Errata
dans la 1&#232;re macro remplacer :
InverseTab 
par  : 
InvTab

jpleroisse · Answer

OK Merci &#224; tous , la m&#233;thode de galopin01 marche tr&#232;s bien.

Etablir un classement (Excel/VBA)

6 réponses

Discussions similaires