Sub Transpose1()
Dim a, b(), x As Long, i As Long, j As Byte, k As Long
Application.ScreenUpdating = False
Range("A12").CurrentRegion.Clear
With Range("A2").CurrentRegion
x = WorksheetFunction.CountA(.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1))
a = .Value
End With
If x = 0 Then Exit Sub
ReDim b(1 To 3, 1 To x)
For i = 2 To UBound(a, 1)
For j = 2 To UBound(a, 2)
If Not IsEmpty(a(i, j)) Then
k = k + 1
b(1, k) = a(i, 1)
b(2, k) = a(1, j)
b(3, k) = a(i, j)
End If
Next
Next
With Range("A12")
.Resize(, 3) = [{"Ma Référence Produit", "Concurrent", "Référence Concurrent"}]
.Offset(1).Resize(UBound(b, 2), UBound(b, 1)) = _
Application.Transpose(b)
With .CurrentRegion
.VerticalAlignment = xlCenter
.BorderAround ColorIndex:=1, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 36
.Columns(1).Interior.ColorIndex = 6
With .Rows(1)
.BorderAround ColorIndex:=1, Weight:=xlThin
.Interior.ColorIndex = 44
.HorizontalAlignment = xlCenter
.WrapText = True
End With
End With
End With
Application.ScreenUpdating = True
End Sub