Demande d'aide

Bonjour,

J'ai un énorme tableau renseignant les moyennes générales des élèves de la 3ème année collégiale de plusieurs établissements scolaires.

J'aimerai extraire sur un nouveau tableau, les trois premiers élèves de chaque établissement qui ont eu la moyenne la plus élevée.

Je vous prie de bien vouloir m’aider pour trouver une solution. Merci.

Ci-joint le tableau en question

81merites.xlsx (307.39 Ko)

Salut Mouncef,

voici, un double-clic en [A1] démarre la macro...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract()
Dim iIdx%
'
Cancel = True
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
    Application.ScreenUpdating = False
    '
    Range("H:M").ClearContents
    Range("H:M").Borders.LineStyle = xlNone
    Range("H:M").Interior.Color = RGB(255, 255, 255)
    '
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:F" & iRow).Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("F2"), order2:=xlDescending, Orientation:=xlTopToBottom
    tData = Range("A1:F" & iRow).Value
    '
    For x = 2 To UBound(tData, 1)
        If tData(x, 1) <> tData(x - 1, 1) Then
            For y = x To x + 2
                iIdx = iIdx + 1
                ReDim Preserve tExtract(6, iIdx)
                If y = x Then tExtract(0, iIdx - 1) = tData(x, 1)
                For Z = 2 To 6
                    tExtract(Z - 1, iIdx - 1) = tData(y, Z)
                Next
            Next
        End If
    Next
    Range("H2").Resize(iIdx, 6).Value = WorksheetFunction.Transpose(tExtract)
    '
    Columns("H:M").AutoFit
    For x = 2 To iIdx Step 3
        Range("H" & x & ":M" & x + 2).BorderAround LineStyle:=xlContinuous
        Range("H" & x & ":M" & x + 2).Interior.Color = IIf(Range("H" & x - 1).Interior.Color = RGB(255, 255, 255), RGB(215, 215, 215), RGB(255, 255, 255))
    Next
    '
    Application.ScreenUpdating = True
End If
'
End Sub

A+

17merites.xlsm (316.56 Ko)

Merci pour votre solution généreuse, c'est vraiment gentil de votre part. Problème résolu. Bonne continuation.

Bonjour

Une solution par TCD sans VBA

8merites-tcd.xlsx (515.24 Ko)

Bonjour,

Merci 78chris pour cette solution par tableaux croisés dynamiques. Bonne journée.

Rechercher des sujets similaires à "demande aide"