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) &...
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
Vous êtes mal-voyant ?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
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