Recherche doublon,Masquer et Transposer

Bonjour le forum

Le but de ce fichier et de pouvoir :

1- Masquer les doublons ( suivant un numéro) en fonction du jour de la semaine.

2-Transposer Op1; Op2; Op3;Op4 pour le doublon d'une colonne sur une ligne.

3-Masquer les colonnes Op3 ou Op4 si vide.

Mon support:

Je n'ai pas pu mettre le fichier de base, mais sauf les colonnes D, E, F et G sont sans formules.

Le tableau en feuille 1 est le résultat d'une extraction suivant le filtre sur une semaine Colonne R

Feuille 1 -> J'ai déjà un bout de code dans le fichier, mais cela ne me donne pas la satisfaction voulu.

Feuille 2 -> Le résultat que je souhaite obtenir .

J'essaye d'être le plus explicite possible (Je me base sur les remarques constructives de nos pères de ce forum)

Je me remet à vous pour m'aider.

Merci d'avance

bonjour ledzep,

vous voulez aussi ces couleurs ? Maintenant, je colle les données dans la feuille "blad1"

Sub Dictionaire()
     Set dict = CreateObject("scripting.dictionary")
     dict.comparemode = vbTextCompare

     With Sheets("Feuil2")
          aa = .Range("A6:A" & .Range("A" & Rows.Count).End(xlUp).Row).Resize(, 18).Value2     'la plage & 18 colonnes
     End With

     For i = 1 To UBound(aa)
          skey = Join(Array(aa(i, 1), aa(i, 2), aa(i, 3), aa(i, 8), aa(i, 9)), "|")     'le clef est nom & description & location & début & fin
          If Not dict.exists(skey) Then      'clef nouveau
               dict(skey) = Application.Index(aa, i, 0)     'ajoutez toute la ligne comme item
          Else
               it = dict(skey)

               j1 = 0: b = False             'initialiser
               For j2 = 4 To 7               'les colonnes 4 à 7
                    If aa(i, 4) = it(j2) Then b = True: Exit For     'le OP est déjà connu
                    If j1 = 0 And Len(it(j2)) = 0 Then j1 = j2     'premier élément vide
               Next
               If Not b And j1 > 0 Then it(j1) = aa(i, 4)     'ajouter nouveau OP

               For j1 = 11 To UBound(aa, 2) - 1     'à partir de la colonne 11  jusqu'à l'avant dernière
                    If Len(aa(i, j1)) > 0 Then it(j1) = it(j1) + CDbl(aa(i, j1))     'cumuler les chiffres de ces colonnes
               Next
               dict(skey) = it               'écrire ces nouveaux données vers la dictionaire
          End If
     Next

     With Sheets("blad1")
          .Cells.ClearContents               'RAZ
          ptr = dict.Count                   'nombre de données
          If ptr > 0 Then                    'il y a des données
               If ptr = 1 Then dict.Add dict.Count, dict.items()(0)     'porblème avec un dictionaire avec un record = doublez celui !!!
               .Range("A1").Resize(ptr, UBound(aa, 2)).Value = Application.Index(dict.items, 0, 0)
          End If
     End With

End Sub

Bonjour à tous

bonjour BsAlv

Merci pour ton retour, je regarde cela en fin de journée

Pour les couleurs non merci, j’avais mis cela pour plus de facilité de repérage pour le développement.

Bonne après-midi à tous