Remplir des tableaux à partir de la valeur de cellules

Bonjour,

J'ai une question pas très facile à formuler. J'ai dans une feuille une base de données avec 5 colonnes. Dans la première colonne il y a 4 différentes valeurs que j'ai nommé Objet1, Objet2, Objet3 et Objet4. Dans une autre feuille, j'ai 4 tableaux (un pour chaque objet). J'aimerai que toutes les valeurs lié à chaque objet apparaissent dans chaque tableau en fonction de l'objet. Par exemple, si je change une ligne de la BDD de l'objet3 à l'objet4, j'aimerai que la ligne correspondante passe du troisième tableau au quatrième.

N'hésitez pas si vous avez des questions.

Merci

bonjour,

y a-t-il une des colonnes qui pourrait être utilisé comme identifiant unique ? cela semble être le cas pour la colonne 2 dans l'exemple donné.

Bonjour,

Merci de ta réponse, oui je me base sur les valeurs de la colonne 2.

Bonsoir,

Avec ton ton exemple, on ne connaît pas la finalité de ce besoin d'éclater ta feuille BDD en x tableaux sur la feuille Tables.

Si il y des calculs à effectuer, il faudrait peu-être envisager l'utilisation d'un TCD.

Peux-tu préciser l'usage de cet éclatement?

Cdlt

Bonjour,

J'ai simplifié mon projet pour qu'il soit plus simple à comprendre car j'ai beaucoup plus de données. J'ai pensé au tableau croisé dynamique mais cela me semble pas possible car les tableaux que je souhaite sont référencés et donc je ne peux pas modifier la mise en forme.

Mon besoin est : je veux simplement renvoyer toutes les valeurs de la colonne 2 par rapport à l'objet de la colonne1. Comme il y a 4 objets, il me faut 4 tableaux. Par contre comme je l'ai dis plus haut, je ne peux pas modifier la mise en forme des tableaux mais uniquement les valeurs.

Merci.

Bonjour,

Je me permet de relancer mon sujet.

Merci.

Bonjour,

C'est impossible de faire ça avec Excel ??

Ok j'abandonne, merci à tous.

bonsoir, monsieur l'impatient énervé que je n'ai pas vraiment envie d'aider ! Qui a l'air d'oublier que les gens qui aident sont bénévoles.

mais comme j'avais travaillé sur un code, je le mets quand même à disposition en toute magnanimité

bonne chance !

Sub gentables()

Dim ws As Worksheet
Dim ws1 As Worksheet

Set ws = Worksheets("BDD")
Set ws1 = Worksheets("Feuil3"):  'résultat dans Feuil3
derlig = ws.Range("a:a").End(xlDown).Row
ws1.Cells.Clear
ws1.Range("A1") = "TITRE"
    ws1.Range("A1:E1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ws.Range("a1:E" & derlig).Copy
    ws1.Range("a2").Select
    ActiveSheet.Paste
    Columns("A:E").Select
    Application.CutCopyMode = False
   ws1.Sort.SortFields.Clear
    ws1.Sort.SortFields.Add Key:=Range("A1:A" & derlig) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws1.Sort
        .SetRange Range("A2:E" & derlig)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
rup = ws1.Cells(derlig, 1)
For i = derlig - 1 To 3 Step -1
 If ws1.Cells(i, 1) <> rup Then
    ws1.Rows("1:2").Select
    Selection.Copy
    ws1.Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown
    Application.CutCopyMode = False
    ws1.Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    rup = ws1.Cells(i, 1)
 End If
Next i
Set ws = Nothing
Set ws1 = Nothing
End Sub