Recomposer un tableau selon critère

Question

Je viens vous voir aujourd'hui avec un tableau capricieux. Je dispose d'un tableau propre (capricieux). Mais j'ai un soucis... c'est que ce tableau tel qu'il a était conçu, représente 2 dimensions qui se chevauchent, super pratique pour faire des tris. Pour expliquer : L'unité du tableau, c'est le document, à absolument conserver. Il est exprimé en ligne, en bleue claire. Ce sont les champs en police rouge qui concernent le document et qui sont absolument à conserver. La dimension chevauchante, ce sont les individus présents dans le document. Ils sont étiquetés par une clé de filtre "Oui (je garde)", "Non (je dégage)", et ils ont des champs qui les concernant "noms 1 à 8". Globalement, ce que je souhaiterais, c'est uniquement supprimer les individus dont le filtre est "Non"... - Tout en conservant intacte ma ligne document et ses champs rouges, - Tout en conservant les individus marqués "Oui" et leurs champs "noms 1 à 8", - Tout en dégageant les individus marqués"Non" et leurs champs "noms 1 à 8", - Gérer une exception lorsque l'individu "Non" se situe pile sur la ligne bleue , pour supprimer uniquement les champs de l'individu, et faire remonter en face du document les individus "Oui". - Tout en gardant cette structure de "Pack-ligne", document par document. - Tout en exécutant le programme sur 150 + documents. Une image vaut mieux que mille mot, un superbe fichier en exemple. J'exprime toute ma sollicitude à celui qui aurait une solution à me proposer. Klin89, gmb, R@chid, pitié... Alors j'ai fais mes devoirs, voici déjà les programmes que j'ai utilisé pour structurer le tableau pour l'analyse finale. Malheureusement j'ai produis mes analyses sur un tableau filtrer "oui" "non" ce qui a bien sur tout décallé... donc tout est faux. NB : à mon avis faire le 1er travail (supprimer les individus "Non") n'est pas compliqué lorsqu'ils sont sous la ligne bleue, en revanche, c'est plus chiant quand ils sont pile dessus, car il faut faire remonter le tout... Option Explicit Sub inserer_une_ligne_chaque_fois__change_pack() Dim i As Long Application.ScreenUpdating = False Application.Calculation = xlManual With Worksheets("Feuil1") 'Nom de feuille à adapter For i = .Range("A" &amp; Rows.Count).End(xlUp).Row To 10 Step -1 If .Range("A" &amp; i).Value &lt;&gt; "" Then .Range("A" &amp; i).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove End If Next i End With Application.Calculation = xlAutomatic End Sub Option Explicit Dim ln&amp;, lgn&amp;, derln&amp;, derCol&amp;, j&amp;, k&amp;, t&amp; Sub Recompresser_document_en_pack_sur_1_seule_ligne() 'lnD = 2 lgn = 2 derln = 1 derCol = Cells(1, 1).End(xlToRight).Column Range(Cells(2, 10), Cells(Cells(Rows.Count, 10).End(xlUp)(2).Row, derCol + 9)).ClearContents 'préciser le # de la colonne de sortie du tableau, la différence entre le # de la dernière colonne et le numéro de la dernière colonne du 1er tableau For j = 2 To derCol If Cells(Rows.Count, j).End(xlUp).Row &gt; derln Then derln = Cells(Rows.Count, j).End(xlUp).Row End If Next j For ln = 2 To derln k = 0 ': t = 0 Range("J" &amp; lgn) = Range("A" &amp; ln + k) ' préciser la colonne de sortie du tableau, équivalent "lettre" du rang exprimé plus haut (J = 10) Do While Range("A" &amp; ln + 1 + k) = "" And ln + 1 + k &lt;= derln + 1 For j = 2 To derCol If Cells(ln + 1 + k, j) &lt;&gt; "" Then Cells(lgn, j + 9) = Cells(lgn, j + 9) &amp; Cells(ln + k, j) &amp; ";" 'marquer ici le résultat de la différence vu plus haut Else Cells(lgn, j + 9) = Cells(lgn, j + 9) &amp; Cells(ln + k, j) 'marquer ici le résultat de la différence vu plus haut End If Next j 't = t + 1 k = k + 1 Loop ln = ln + k lgn = lgn + 2 Next ln End Sub sub degager_tous_les_espaces_() For Each cellule In ActiveSheet.UsedRange cellule.Value = LTrim(cellule.Value) Next end sub '' =SUPPRESPACE(A2) Sub dedoublonnage_dans une cellule_,_() Dim Dico, c As Range Set Dico = CreateObject("Scripting.Dictionary") On Error Resume Next For Each c In Range("A1", Range("A65536").End(xlUp)) tablo = Split(c, ",") For Each Item In tablo Item = Application.Trim(Item) Dico.Add Item, "" Next Item c = "" For Each k In Dico.keys c = c &amp; ", " &amp; k Next c = Left(Right(c, Len(c) - 2), Len(c) - 2) For Each k In Dico.keys Dico.Remove k Next Next c End Sub Sub decliner_noms_colonne() Dim feuilleSource As Worksheet Dim feuilleCible As Worksheet Dim iSource, iCible, i As Integer Dim currentA, currentB As String Dim currentSplit() As String Set feuilleSource = Worksheets(2) 'A modifier, la feuille contenant les données originales Set feuilleCible = Worksheets(3) 'A modifier, la feuille où l'on veut le résultat 'Initialisation des compteurs de lignes iSource = 1 iCible = 1 Do While feuilleSource.Cells(iSource, "A").Value &lt;&gt; "" 'Tant qu'il y a qq chose en colonne A currentA = feuilleSource.Cells(iSource, "A").Value currentB = feuilleSource.Cells(iSource, "B").Value 'On décompose la chaine par les virgules currentSplit = Split(currentB, ",") 'Pour chaque élément, on l'écrit dans la feuille cible For i = 0 To UBound(currentSplit) feuilleCible.Cells(iCible, "A").Value = currentA feuilleCible.Cells(iCible, "B").Value = LTrim(currentSplit(i)) 'En enlevant les espaces à gauche iCible = iCible + 1 Next i iSource = iSource + 1 Loop End Sub Sub dedoublonnage_noms() Range("A1", "B5000").RemoveDuplicates Columns:=Array(1) End Sub...

bouben · Accepted Answer

Super ! Alors on reste là-dessus Bonne journée Bouben...

bouben · Answer

Si j'ai bien compris, on veut supprimer toutes les lignes à "Non", sauf les lignes de titre. Ci-joint une proposition à tester. On copie en bloc dans l'onglet "Arrivée" Et on balaie de haut en bas. Si ligne de titre, on continue à descendre Sinon, on supprime la ligne s'il y a un non. Cela me semble trop simple pour être le résultat souhaité Bonne soirée Bouben...

bouben · Answer

Effectivement, c'est plus compliqué Ci-joint une nouvelle version à tester. Bonne soirée Bouben...