Sub Croix2()
Dim a()
Dim t()
Dim mMax
Dim Z
Set ws1 = Sheets("Base"): Set ws2 = Sheets("Sheet1")
Set titre = ws1.[B23:C23]
last = ws1.[B65000].End(xlUp).Row
' selection du tableau sans les titres
ws1.Range("B23").CurrentRegion.Offset(1).Resize(Range("B23").CurrentRegion.Rows.Count - 1, 8).Select
a = Selection.Value ' tableau
ReDim Preserve t(1 To 200, 1 To 3) ' à revoir, je rame avec les tableaux !!!
' effacer les colonnes A-B-C de la feuille 2
ws2.[A:C].ClearContents
li = 1
' on prends les donnes de la colonne 3 à 8
For col = 3 To 8
For i = LBound(a) To UBound(a)
If a(i, col) <> "" Then
t(li, 1) = a(i, 1) ' données du tableau dans tableau provisoire T
t(li, 2) = a(i, 2)
t(li, 3) = Cells(23, col + 1) ' titre de la ligne 23
li = li + 1
End If
Next i
Next col
Debug.Print UBound(t)
ws2.[A3].Resize(UBound(t), 3) = t
' ajout des titres en feuille 2
titre.Copy Destination:=ws2.[A2]: ws2.[C2].Value = "Couleur"
End Sub