XL 2021 Remplir des listes à partir d'une base de données

[chajmi]

Bonjour,
J'ai une base de données en feuille "A"
Comment renseigner automatiquement mes tableaux en feuille "B"

Merci de votre aide

 

[Phébus]

Bonjour,
J'ai une base de données en feuille "A"
Comment renseigner automatiquement mes tableaux en feuille "B"

Merci de votre aide

bonsoir chajmi

Voici une proposition.

Bonne soirée

 

[OKBI]

Bonsoir,
Un essai avec PQ
Cdt

 

[Jacky67]

Bonjour,
J'ai une base de données en feuille "A"
Comment renseigner automatiquement mes tableaux en feuille "B"

Merci de votre aide

Bonjour à tous,
Sinon, par formules en gardant la structure donnée

 

[job75]

Bonjour chajmi, le forum,

Ou en VBA, le code de la feuille "B" :

Private Sub Worksheet_Activate()
Dim dest As Range, n%
Set dest = [B3]
Application.ScreenUpdating = False
Rows(dest.Row + 1 & ":" & Rows.Count).Delete 'RAZ
With Sheets("A").[A3].CurrentRegion
    For n = 1 To .Columns.Count - 2
        .Columns(1).Resize(, 2).Copy dest(2, 4 * n - 3)
        .Columns(2 + n).Copy dest(2, 4 * n - 1)
    Next
End With
End Sub

La macro se déclenche quand on active la feuille.

A+

 

[chajmi]

Merci à tous pour vos propositions. Je me permets d'affiner ma demande.
J'ai besoin qu'il ne reste dans la liste en feuille B, uniquement les personnes concernées, triées par ordre alphabétique.
Je voudrais aussi que s'affiche des informations supplémentaires liées à chaque personne (info 1, info 2, info 3 ...)
Merci d'avance pour le temps passé.

 

[Nain porte quoi]

Hello,

en reprenant les propositions de Phébus et OKBI

 

[job75]

Bonjour chajmi, le forum,

Toujours en VBA, la macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim gr$, source As Range, col%
gr = CStr(Sh.[B2])
If Not gr Like "Groupe*" Then Exit Sub
Set source = Sheets("A").Rows("3:" & Sheets("A").Cells.SpecialCells(xlCellTypeLastCell).Row)
Application.ScreenUpdating = False
With Sh
    .Rows("3:" & .Rows.Count).Delete 'RAZ
    source.Copy .Rows(3) 'copier-coller
    For col = .Cells(3, .Columns.Count).End(xlToLeft).Column To 2 Step -1
        If .Cells(3, col) Like "Groupe*" Then _
            If .Cells(3, col) = gr Then .Cells(3, col) = "" _
                Else .Columns(col).Delete 'supprime les colonnes non concernées
    Next col
    .Range("C4:C" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'supprime les lignes des cellules vides
    .Rows("4:" & .Rows.Count).Sort .Columns(2), xlAscending, Header:=xlNo 'tri alphabétiqye
    .Columns.AutoFit 'ajustement largeurs
    Union(.Columns(1), .Columns(3)).ColumnWidth = 5
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Elle se déclenche quand on active les feuilles.

A+

 

[job75]

La macro précédente beugue s'il n'y a pas de cellules vides [Edit : en colonne C], il faut ajouter On Error Resume Next :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim gr$, source As Range, col%
gr = CStr(Sh.[B2])
If Not gr Like "Groupe*" Then Exit Sub
Set source = Sheets("A").Rows("3:" & Sheets("A").Cells.SpecialCells(xlCellTypeLastCell).Row)
Application.ScreenUpdating = False
With Sh
    .Rows("3:" & .Rows.Count).Delete 'RAZ
    source.Copy .Rows(3) 'copier-coller
    For col = .Cells(3, .Columns.Count).End(xlToLeft).Column To 2 Step -1
        If .Cells(3, col) Like "Groupe*" Then _
            If .Cells(3, col) = gr Then .Cells(3, col) = "" _
                Else .Columns(col).Delete 'supprime les colonnes non concernées
    Next col
    On Error Resume Next 'si aucune SpecialCell (vide)
    .Range("C4:C" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'supprime les lignes des cellules vides
    .Rows("4:" & .Rows.Count).Sort .Columns(2), xlAscending, Header:=xlNo 'tri alphabétiqye
    .Columns.AutoFit 'ajustement largeurs
    Union(.Columns(1), .Columns(3)).ColumnWidth = 5
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub

 

[ALS35]

Bonjour à tous,
Dans la lignée des formules simples et dynamiques des posts précédents, une formule unique et valable sur chacune des feuilles, à placer en A4 en supprimant au préalable les valeurs déjà présentes) :

=LET(g;FILTRE(A!C4:F13;A!C3:F3=B2);TRIER(FILTRE(ASSEMB.H(A!A4:B13;g;A!G4:L13);g="x")&"";2))

Cordialement
Edit : arf désolé les fonctions CHOISIRCOLS et ASSEMB.H ne sont pas disponibles sous Excel 2021

 

[chajmi]

La macro précédente beugue s'il n'y a pas de cellules vides [Edit : en colonne C], il faut ajouter On Error Resume Next :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim gr$, source As Range, col%
gr = CStr(Sh.[B2])
If Not gr Like "Groupe*" Then Exit Sub
Set source = Sheets("A").Rows("3:" & Sheets("A").Cells.SpecialCells(xlCellTypeLastCell).Row)
Application.ScreenUpdating = False
With Sh
    .Rows("3:" & .Rows.Count).Delete 'RAZ
    source.Copy .Rows(3) 'copier-coller
    For col = .Cells(3, .Columns.Count).End(xlToLeft).Column To 2 Step -1
        If .Cells(3, col) Like "Groupe*" Then _
            If .Cells(3, col) = gr Then .Cells(3, col) = "" _
                Else .Columns(col).Delete 'supprime les colonnes non concernées
    Next col
    On Error Resume Next 'si aucune SpecialCell (vide)
    .Range("C4:C" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'supprime les lignes des cellules vides
    .Rows("4:" & .Rows.Count).Sort .Columns(2), xlAscending, Header:=xlNo 'tri alphabétiqye
    .Columns.AutoFit 'ajustement largeurs
    Union(.Columns(1), .Columns(3)).ColumnWidth = 5
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Bonjour votre proposition est très intéressante, mais je n'arrive pas à l'appliquer à mon fichier final (Qui est différent du fichier NEW ESSAI).
Je vous envoies un fichier plus proche du réel.
A partir de la feuille BASE, je veux remplir les feuilles 1, 2, 3, et 4
Merci d'avance si vous pouvez prendre le temps de me l'adapter.

 

[job75]

Bonjour chajmi, le forum,

Non seulement votre dernier fichier est différent mais en l'état on ne peut rien en faire.

C'est à vous de le rendre cohérent et de nous dire ce que vous voulez faire.

A+

 

[ALS35]

Bonjour à tous,
Avec de légères modification sur les noms des colonnes, une tentative par formules, a priori valables pour Excel 2021. Tu y trouveras peut-être de l'inspiration.
Cordialement

 

[job75]

Bonsoir chajmi, le forum,

En effet ALS35 a raison, il suffit de quelques corrections, le code dans Thisworkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim P As Range, numlig As Range, i As Variant, numcol As Range
If Not IsNumeric(Sh.Name) Then Exit Sub
Application.ScreenUpdating = False
Sh.[C6].Resize(Sh.Rows.Count - 5, Sh.Columns.Count - 2).ClearContents 'RAZ
On Error Resume Next 'si aucune SpecialCell
Set P = Sh.Columns(2).SpecialCells(xlCellTypeConstants, 1)
With Sheets("BASE")
    For Each numlig In P
        i = Application.Match(numlig, .Range("A5:A" & .Rows.Count), 0)
        For Each numcol In Sh.Rows(2).SpecialCells(xlCellTypeConstants, 1)
            If IsNumeric(i) Then Sh.Cells(numlig.Row, numcol.Column) = .Cells(i + 4, numcol)
    Next numcol, numlig
End With
P.EntireRow.Sort Sh.Columns(3), xlAscending, Sh.Columns(2), , xlAscending, Header:=xlNo 'tri sur 2 colonnes
ActiveWindow.ScrollRow = 6 'cadrage
End Sub

Activez les feuilles 1 2 3 4.

A+

 

[job75]

On peut éviter facilement le repérage des colonnes par des nombres :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim P As Range, Q As Range, reflig As Range, i As Variant, refcol As Range, j As Variant
If Not IsNumeric(Sh.Name) Then Exit Sub
Application.ScreenUpdating = False
Sh.[C6].Resize(Sh.Rows.Count - 5, Sh.Columns.Count - 2).ClearContents 'RAZ
On Error Resume Next 'si aucune SpecialCell
Set P = Sh.Columns(2).SpecialCells(xlCellTypeConstants, 1)
Set Q = Sh.Rows(4).SpecialCells(xlCellTypeConstants, 2)
With Sheets("BASE")
    For Each reflig In P
        i = Application.Match(reflig, .Range("A4:A" & .Rows.Count), 0)
        For Each refcol In Q
            j = Application.Match(refcol, .Rows(2), 0)
            If IsNumeric(i) And IsNumeric(j) Then Sh.Cells(reflig.Row, refcol.Column) = .Cells(i + 3, j)
    Next refcol, reflig
End With
P.EntireRow.Sort Sh.Columns(3), xlAscending, Sh.Columns(2), , xlAscending, Header:=xlNo 'tri sur 2 colonnes
ActiveWindow.ScrollRow = 5 'cadrage
End Sub