Bonsoir à tous,
A tester :
Option Explicit
Sub ventile()
Dim a, i As Long, j As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Milestones").[a1].CurrentRegion.Value2
For j = 2 To UBound(a, 2)
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, j)) Then
If Not dico.exists(a(1, j)) Then
Set dico(a(1, j)) = CreateObject("Scripting.Dictionary")
End If
dico(a(1, j))(a(i, j)) = dico(a(1, j))(a(i, j)) & _
IIf(dico(a(1, j))(a(i, j)) <> "", "|", "") & a(i, 1)
End If
Next
Next
Application.ScreenUpdating = False
With Sheets("matrice").[a1].CurrentRegion
With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
.ClearContents
.NumberFormat = "@"
End With
For i = 2 To .Rows.Count
If dico.exists(.Cells(i, 1).Value) Then
For j = 2 To .Columns.Count
If dico(.Cells(i, 1).Value).exists(.Cells(1, j).Value2) Then
.Cells(i, j).Value = dico(.Cells(i, 1).Value)(.Cells(1, j).Value2)
End If
Next
End If
Next
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
Le code réaménagé, c'est mieux ainsi :
Option Explicit
Sub ventile()
Dim a, i As Long, j As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Milestones").[a1].CurrentRegion.Value2
For j = 2 To UBound(a, 2)
Set dico(a(1, j)) = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, j)) Then
dico(a(1, j))(a(i, j)) = dico(a(1, j))(a(i, j)) & _
IIf(dico(a(1, j))(a(i, j)) <> "", Chr(10), "") & a(i, 1)
End If
Next
Next
Application.ScreenUpdating = False
With Sheets("matrice").[a1].CurrentRegion
With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
.ClearContents
.NumberFormat = "@"
End With
For i = 2 To .Rows.Count
If dico.exists(.Cells(i, 1).Value) Then
If dico.Item(.Cells(i, 1).Value).Count > 0 Then
For j = 2 To .Columns.Count
If dico(.Cells(i, 1).Value).exists(.Cells(1, j).Value2) Then
.Cells(i, j).Value = dico(.Cells(i, 1).Value)(.Cells(1, j).Value2)
End If
Next
End If
End If
Next
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89