Suppression doublons et tableau activite

[dl87671]

Bonjour,
A partir d'un fichier constitué de plusieurs lignes (onglet Départ):
1 ligne par code membre et une activité (RD, MN ou AB).

Est-il possible de créer un onglet Arrivée, avec une liste unique de code membre avec un récapitulatif pour chaque activité avec une X ?

Pour ma part j'ai dupliqué le fichier, supprimer les doublons, puis avec la formule sommeprod du départ, j'ai rempli mon fichier.
Y a t-il une façon plus rapide avec formule ou macro pour résoudre mon problème ?
D'avance merci pour vos réponses.

 

[klin89]

Bonsoir dl87671

Vois ceci :
Quel est l'intérêt de garder la colonne 3, puisque l'on restitue les intitulés dans la ligne d'en-têtes

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico As Object, txt As String
    Set dico = CreateObject("Scripting.Dictionary")
    a = Sheets("Départ").Range("a1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) + 1, 1 To UBound(a, 1) + 2)
    n = 1: t = 3: b(1, 1) = a(1, 1)
    b(1, 2) = a(1, 2): b(1, 3) = a(1, 3)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
            If Not dico.exists(txt) Then
                n = n + 1: dico(txt) = n
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, 3)
            End If
            If Not .exists(a(i, 3)) Then
                t = t + 1: .Item(a(i, 3)) = t
                b(1, t) = a(i, 3)
            End If
            b(dico(txt), .Item(a(i, 3))) = "x"
        Next
    End With
    Application.ScreenUpdating = False
    'restitution et mise en forme
    With Sheets("Arrivée")
        .Cells.Clear
        With .Cells(1).Resize(n, t)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows(1).BorderAround Weight:=xlThin
            .Columns.ColumnWidth = 12
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[Lone-wolf]

Bonjour dl, klin

@ klin: entre nous... c'est clean

 

[belkacem_64]

salut
un autre code

Sub Calcule()

Dim sh As Worksheet, shh As Worksheet, _
j As Long, R As Long, _
RR As Long, LsRow As Long, _
C As Range, Ary()
Set sh = Sheets("Départ"): Set shh = Sheets("Arrivée")
With shh.Range("A2:F" & shh.Range("a" & Rows.Count).End(xlUp).Row + 2)
.ClearContents: .Borders.LineStyle = xlNone
End With
With sh
LsRow = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Row
Application.ScreenUpdating = False
For j = 2 To LsRow
If WorksheetFunction.CountIf(.Range("A2:A" & j), .Range("A" & j)) = 1 Then
R = R + 1
ReDim Preserve Ary(1 To 3, 1 To R)
Ary(1, R) = .Cells(j, 1): Ary(2, R) = .Cells(j, 2): Ary(3, R) = .Cells(j, 3)
End If
Next
If R Then shh.Range("A2").Resize(R, 3) = Application.Transpose(Ary)
End With: If Err Then Err.Clear
RR = shh.Range("a" & Rows.Count).End(xlUp).Row
For i = 2 To RR: For y = 4 To 6
With shh.Cells(i, y)
.Formula = "=SUMPRODUCT((Départ!A2:A9=" & """" & Cells(i, 1) & """" & " )*(Départ!C2:C9=" & """" & Cells(1, y) & """" & "))"
.Value = .Value
End With
Next
Next
For Each C In shh.Range("D2:F" & RR)
If C.Value = 1 Then C.Value = "X" Else C.Value = ""
Next
shh.Range("A2:F" & RR).Borders.Value = 1
Set sh = Nothing: Set shh = Nothing: Erase Ary
Application.ScreenUpdating = True

End Sub

 

[Lone-wolf]

Bonjour belkacem

Modifie le message en mettant le code dans le options(icône à gauche de la disquette) Code > VB. Ce sera plus agréable à lire.

 

[belkacem_64]

Merci Lone-Wolf
J'arrive pas a le faire , j'ai essayé plusieurs fois mais ca ne marche pas . je ne sais pas pourquoi