XL 2016 création une liste sous une colonne

yaraar

XLDnaute Junior
Bonjour les experts:

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

Pièces jointes

  • Copie de oppo.xlsm
    103.4 KB · Affichages: 16
Solution
Bonsoir yaraar, chris,

Voyez le fichier joint et cette macro dans ThisWorkbook :
VB:
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) &...

job75

XLDnaute Barbatruc
Bonsoir yaraar, chris,

Voyez le fichier joint et cette macro dans ThisWorkbook :
VB:
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.
 

Pièces jointes

  • Copie de oppo(1).xlsm
    106.4 KB · Affichages: 18
Dernière édition:

yaraar

XLDnaute Junior
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
1638303200236.png
 

job75

XLDnaute Barbatruc
Bonjour yaraar,

Voici quand même la nouvelle macro Workbook_SheetActivate :
VB:
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+
 

Discussions similaires

Réponses
20
Affichages
719

Statistiques des forums

Discussions
311 725
Messages
2 081 949
Membres
101 851
dernier inscrit
vaiata