XL 2016 création une liste sous une colonne

[yaraar]

Bonjour les experts:

j'ai besoin d'aide pour mettre une liste sous chaque colonne comme le cas ci joint

 

[chris]

Bonjour

Une solution PowerQuery + TCD : j'ai fait les 3 premiers TCD

 

[job75]

Bonsoir yaraar, chris,

Voyez le fichier joint et cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If LCase(Sh.Name) = "bd" Or LCase(Sh.Name) = "liste" Then Exit Sub
Dim d As Object, dd As Object, ddd As Object, tablo, nf$, i&, x$, lig&, a, b, ncol%, resu(), j As Byte, k%
'---tableau source---
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
Set ddd = CreateObject("Scripting.Dictionary")
tablo = [Tableau2] 'tableau structuré
nf = LCase(Sh.Name)
For i = 1 To UBound(tablo)
    If LCase(Left(tablo(i, 3), 31)) = nf Then 'le nom de la dernière feuille est limité à 31 caractères
        d(tablo(i, 2)) = ""
        dd(tablo(i, 1)) = ""
        x = tablo(i, 2) & tablo(i, 1) & tablo(i, 4)
        If Not ddd.exists(x) Then ddd(x) = tablo(i, 5)
    End If
Next i
'---tableau des résultats---
Application.ScreenUpdating = False
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
lig = 4 '1ère ligne de destination
Sh.Rows(lig & ":" & Sh.Rows.Count).Delete xlUp 'RAZ
If d.Count = 0 Then Exit Sub 'sécurité
a = d.keys
b = dd.keys
ncol = dd.Count + 1
'---ligne des dates---
Sh.Cells(lig, 2).Resize(, ncol - 1) = b
Sh.Rows(lig).Font.Bold = True 'gras
'---lignes suivantes---
ReDim resu(1 To 5 * d.Count, 1 To ncol)
For i = 1 To UBound(resu) Step 5
    resu(i, 1) = a((i - 1) / 5)
    resu(i + 1, 1) = "HO to 3G"
    resu(i + 2, 1) = "S1 HO"
    resu(i + 3, 1) = "TAU (connected)"
    resu(i + 4, 1) = "X2 HO"
    For j = 1 To 4
        For k = 2 To ncol
            resu(i + j, k) = ddd(resu(i, 1) & b(k - 2) & resu(i + j, 1))
    Next k, j
    With Sh.Cells(lig + i, 1)
        .Font.Bold = True 'gras
        .Interior.Color = 16777164  'bleu
        .Cells(1, 2).Resize(, ncol - 1).Merge 'fusion
    End With
Next i
'---restitution---
Sh.Cells(lig + 1, 1).Resize(UBound(resu), ncol) = resu
Sh.Cells(lig, 1).Resize(UBound(resu) + 1, ncol).Borders.Weight = xlThin 'bordures
Sh.Columns.AutoFit 'ajuste les largeurs
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub

Elle se déclenche quand on active une feuille.

Comme on le voit 3 Dictionary sont utilisés.

Edit : correction car le nom de la dernière feuille est limité à 31 caractères.

Bonne nuit.

 

[yaraar]

Bonjour job;

tu as oublié de joindre le fichier

 

[job75]

Bonjour yaraar, le forum,

J'ai fait une correction juste avant votre message et le fichier est bien joint.

A+

 

[chris]

De rien 🙄

 

[yaraar]

Bonsoir ;
je n'ai pas pu remplir le tableau , j'ai essayé la formule index equiv mais ça na pas marché.

y'a t'il une autre formule ou bien par VBA

 

[job75]

Bonsoir ;
je n'ai pas pu remplir le tableau , j'ai essayé la formule index equiv mais ça na pas marché.

y'a t'il une autre formule ou bien par VBA

Vous êtes mal-voyant ?

 

[yaraar]

Bonjour job 75

c'est bon j'ai pu comprendre la trame , merci job 75

 

[yaraar]

Bonjour job 75;

j'ai ajouté une colonne au nom de ''cell'' que dois je modifier dans le code source pour que le tableau soit rempli

merci

 

[job75]

Bonsoir yaraar,

Je vous ai donné une solution pour la macro Worksheet_Change sur ce fil :

https://www.excel-downloads.com/threads/plantage-au-niveau-excel-2016.20062208/page-2#post-20473182

Pour la macro Workbook_SheetActivate c'est le même principe, à vous d'adapter, trop c'est trop !

A+

 

[job75]

Bonjour yaraar,

Voici quand même la nouvelle macro Workbook_SheetActivate :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If LCase(Sh.Name) = "bd" Or LCase(Sh.Name) = "liste" Then Exit Sub
Dim d As Object, dd As Object, ddd As Object, tablo, nf$, i&, x$, lig&, a, b, ncol%, resu(), j As Byte, k%
'---tableau source---
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
Set ddd = CreateObject("Scripting.Dictionary")
tablo = [Tableau2] 'tableau structuré
nf = LCase(Sh.Name)
For i = 1 To UBound(tablo)
    If LCase(Left(tablo(i, 4), 31)) = nf Then 'le nom de la dernière feuille est limité à 31 caractères
        x = tablo(i, 2) & " ; " & tablo(i, 3)
        d(x) = ""
        dd(tablo(i, 1)) = ""
        x = x & tablo(i, 1) & tablo(i, 5)
        If Not ddd.exists(x) Then ddd(x) = tablo(i, 6)
    End If
Next i
'---tableau des résultats---
Application.ScreenUpdating = False
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
lig = 4 '1ère ligne de destination
Sh.Rows(lig & ":" & Sh.Rows.Count).Delete xlUp 'RAZ
If d.Count = 0 Then Exit Sub 'sécurité
a = d.keys
b = dd.keys
ncol = dd.Count + 1
'---ligne des dates---
Sh.Cells(lig, 2).Resize(, ncol - 1) = b
Sh.Rows(lig).Font.Bold = True 'gras
'---lignes suivantes---
ReDim resu(1 To 5 * d.Count, 1 To ncol)
For i = 1 To UBound(resu) Step 5
    resu(i, 1) = a((i - 1) / 5)
    resu(i + 1, 1) = "HO to 3G"
    resu(i + 2, 1) = "S1 HO"
    resu(i + 3, 1) = "TAU (connected)"
    resu(i + 4, 1) = "X2 HO"
    For j = 1 To 4
        For k = 2 To ncol
            resu(i + j, k) = ddd(resu(i, 1) & b(k - 2) & resu(i + j, 1))
    Next k, j
    With Sh.Cells(lig + i, 1)
        .Font.Bold = True 'gras
        .Interior.Color = 16777164  'bleu
        .Cells(1, 2).Resize(, ncol - 1).Merge 'fusion
    End With
Next i
'---restitution---
Sh.Cells(lig + 1, 1).Resize(UBound(resu), ncol) = resu
Sh.Cells(lig, 1).Resize(UBound(resu) + 1, ncol).Borders.Weight = xlThin 'bordures
Sh.Columns.AutoFit 'ajuste les largeurs
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub

A+