Faire un lien entre 2 onglet pour appeler deux colonnes

Question

Je suis actuellement en possession d'un tableau qu'il me faudrait automatiser. Dans mon premier Onglet, je référence différentes idées qui peuvent modifier une ou plusieurs parties de mon ensemble; 3 colonnes avec le numéro de l'idée, la ou les pièces impactées et enfin le nom de l'idée. Je précise que plusieurs idées peuvent agir sur le même pièce. Dans mon deuxième onglet, j'ai 5 colonnes : La pièce impactée (récupéré du tableau précédent Le numéro de l'idée Son Nom (idée) Le numéro de la seconde idée (si il y a) Son Nom (Idée 2) J'aimerai donc a chaque modification ou ajour d'une idée pouvoir avoir la liste dans le second onglet avec les pièces, les idées et comme ca pouvoir savoir si plusieurs idées peuvent interagir sur le même pièce. Je vous mets un tableau test pour mieux comprendre mon problème. Merci d'avance pour votre aide. Bien à vous, FloBru...

MFerrand · Answer

Au fond, est-ce que tu veux que l'on produise ton second tableau à partir du premier ...

MFerrand · Answer

Non seulement c'est possible, mais plus simple d'effacer et reconstruire entièrement à chaque fois...

Sub RéorgTablo()
    Dim d As Object, T(), k, itm, n%, i%, j%, v%, w%
    Set d = CreateObject("Scripting.Dictionary")
    With Worksheets("Board")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            If InStr(.Cells(i, 2), Chr(10)) > 0 Then
                k = Split(.Cells(i, 2), Chr(10))
                For j = 0 To UBound(k)
                    If d.exists(k(j)) Then
                        d(k(j)) = d(k(j)) & ";" & .Cells(i, 1) & ";" & .Cells(i, 3)
                    Else
                        d(k(j)) = .Cells(i, 1) & ";" & .Cells(i, 3)
                    End If
                    v = UBound(Split(d(k(j)), ";"))
                    If v > w Then w = v
                Next j
            Else
                k = .Cells(i, 2)
                If d.exists(k) Then
                    d(k) = d(k) & ";" & .Cells(i, 1) & ";" & .Cells(i, 3)
                Else
                    d(k) = .Cells(i, 1) & ";" & .Cells(i, 3)
                End If
                v = UBound(Split(d(k), ";"))
                If v > w Then w = v
            End If
        Next i
    End With
    ReDim T(d.Count, w + 1): n = 0
    For Each k In d.keys
        n = n + 1: T(n, 0) = k
        itm = Split(d(k), ";")
        For i = 0 To UBound(itm)
            T(n, i + 1) = itm(i)
        Next i
    Next k
    T(0, 0) = "Part": v = 0
    For i = 1 To w + 1 Step 2
        v = v + 1: T(0, i) = "N°" & v: T(0, i + 1) = "Idea " & v
    Next i
    With Worksheets("Part Number").Range("A1")
        With .CurrentRegion
            .ClearContents
            .Interior.ColorIndex = xlColorIndexNone
            .Borders.LineStyle = xlLineStyleNone
        End With
        With .Resize(UBound(T, 1) + 1, UBound(T, 2) + 1)
            .Value = T
            With .Borders
                .LineStyle = xlContinuous: Weight = xlThin
            End With
            .Interior.Color = vbYellow
            .Rows(1).Interior.Color = RGB(217, 217, 217)
        End With
        .Worksheet.Activate
    End With
End Sub

Et quand je dis tout effacer, c'est y compris les bordures et couleurs. On remet en forme à la fin.

S'il y a un N°3, N°4, etc. pour un "Part" donné, le tableau s'étendra automatiquement...

Cordialement.

18flobru-classeur1.xlsm (26.11 Ko)