Sub organisation()
Dim t1(), t2()
Dim i As Byte, j As Byte
t1 = Sheets(1).[D4:F11].Value
ReDim t2(1 To UBound(t1), 1 To UBound(t1, 1))
For i = LBound(t1) To UBound(t1)
For j = LBound(t1, 2) To UBound(t1, 2)
If t1(i, j) <> "" Then
t2(i, 1) = t1(i, j)
Exit For
End If
Next j
Next i
Sheets(1).[D14:F21].Value = t2
End Sub