liste de classement de chaque ahérents

[polo36]

Bonjour,

Je suis nouveau dans ce forum que je trouve trés constructif.
J'ai un projet sur excel et je suis coincé si vous pouvez m’aider,
dans le fichier si joint, je cherche une formule pour importer les classement de chaque adhérent dans une seul cellule et les séparé par une virgule,
merci d'avance .

cordialement

 

[JHA]

Re : liste de classement de chaque ahérents

Bonjour à tous,

En attendant les pros du VBA

JHA

 

[Paf]

Re : liste de classement de chaque ahérents

bonjour et bienvenue sur XLD

une solution par fonction personnalisée:

en K5 : =Classement($A$5:$B$17;G5) à tirer vers le bas

et dans un module standard:

Function Classement(Plage, Ind)
 For Each cel In Plage.Columns(2).Cells
    If cel.Value = Ind Then
        temp = temp & "," & cel.Offset(, -1)
    End If
 Next
 Classement = Right(temp, Len(temp) - 1)
End Function

A+

 

[CBernardT]

Re : liste de classement de chaque ahérents

Bonsoir à tous,

Une solution par VBA qui reprend entièrement le tableau résultat.

 

[polo36]

Re : liste de classement de chaque ahérents

Merci JHA et Paf pour vos réponses,
pour la solution de JHA elle est bien mais comme j'ai une longue liste des prix par adhérent qui dépasse les 100 prix donc ça va être très large le tableau.
et pour la formule de Paf je l'ai testé mais ça me donne pas de résultat.

j’espère avoir d'autre réponses pour que je puisse finir ce tableau, merci encore.

cordialement

 

[polo36]

Re : liste de classement de chaque ahérents

Bonjour,

merci Bernard pour votre solution que je pense adaptable pour mon tableau , merci encore

cordialement

 

[klin89]

Re : liste de classement de chaque ahérents

Bonsoir à tous, 🙂

Même raisonnement que Bernard mais avec un dictionnaire.
Restitution en Feuil2 :

Option Explicit

Sub test()
Dim a, i As Long, w(), x, y, e
    a = Sheets("Feuil1").Range("a4").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                .Item(a(i, 2)) = VBA.Array(a(i, 2), 1, a(i, 4), Empty, a(i, 1))
            Else
                w = .Item(a(i, 2))
                w(1) = w(1) + 1
                w(4) = w(4) & "," & a(i, 1)
                .Item(a(i, 2)) = w
            End If
        Next
        For Each e In .keys
            w = .Item(e)
            w(3) = w(1) / w(2)
            .Item(e) = w
        Next
        x = .Count: y = .items
    End With
    'Restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1)
        .Parent.Cells.Clear
        .Resize(1, 5).Value = Array("Adhérents", "Nbre de prix", "Engagé", "% engagé", "Classement des prix")
        .Offset(1).Resize(x, 5).Value = Application.Index(y, 0, 0)
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 38
                .HorizontalAlignment = xlCenter
            End With
            With .Offset(1).Resize(.Rows.Count - 1)
                With .Resize(, .Columns.Count - 1)
                    .HorizontalAlignment = xlCenter
                End With
                .Columns(4).NumberFormat = "0%"
                .Columns(5).NumberFormat = "@"
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89