1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
| Option Explicit
Sub fusion()
Dim J As Long
Dim I As Integer
Dim K As Long
Dim Tablo
Application.ScreenUpdating = False
Tablo = Application.Transpose(Range(Range("A3"), Cells(4, Cells(3, Columns.Count).End(xlToLeft).Column)))
For J = 5 To Range("A" & Rows.Count).End(xlUp).Row
For K = 2 To UBound(Tablo, 2)
If Range("A" & J) = Tablo(1, K) Then
For I = 2 To UBound(Tablo)
If Cells(J, I) <> "" Then Tablo(I, K) = Cells(J, I)
Next I
Exit For
End If
Next K
If K > UBound(Tablo, 2) Then
ReDim Preserve Tablo(1 To UBound(Tablo), 1 To UBound(Tablo, 2) + 1)
Tablo(1, UBound(Tablo, 2)) = Range("A" & J)
For I = 2 To UBound(Tablo)
If Cells(J, I) <> "" Then Tablo(I, K) = Cells(J, I)
Next I
End If
Next J
With Sheets("résultats")
.Cells.ClearContents
.Range("A1").Resize(UBound(Tablo, 2), UBound(Tablo)) = Application.Transpose(Tablo)
.Select
End With
End Sub |
Partager