Sub aa()
Dim S As Worksheet
Dim R As Range
Dim var
Dim NbCol&
Dim i&
Dim j&
Dim cpt&
Dim Pos&
Dim T()
Dim A$
'---
Set S = Sheets("order_export")
Set R = S.Range("a1").CurrentRegion
R.Copy
Sheets.Add
Set S = ActiveSheet
S.Paste
'---
Set R = Selection
R.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
TrailingMinusNumbers:=True
'---
NbCol& = S.UsedRange.Columns.Count
Set R = R.Offset(0, 1)
R.Cut Destination:=R.Offset(0, NbCol& - 1)
'---
Set R = S.Range(S.Cells(1, NbCol& + 1), S.Cells(R.Rows.Count, NbCol& + 1))
R.TextToColumns Destination:=R.Cells(1, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
TrailingMinusNumbers:=True
'---
Columns(2).Delete Shift:=xlToLeft
'######################################
Set R = S.[a1].CurrentRegion
var = R
'---
On Error Resume Next
For i& = 2 To UBound(var, 1) 'on saute la ligne des titres
For j& = 5 To UBound(var, 2)
If (j& - 2) Mod 3 = 0 Then
A$ = Trim(var(i&, j&))
If A$ = "" Then Exit For
cpt& = cpt& + 1
'--- Coordonnées client ---
ReDim Preserve T(1 To 9, 1 To cpt&)
T(1, cpt&) = var(i&, 1)
T(2, cpt&) = var(i&, 3)
T(3, cpt&) = var(i&, 4)
'--- Quantité ---
A$ = Trim(var(i&, j&))
Pos& = InStr(1, A$, " ")
T(4, cpt&) = Mid(A$, 1, InStr(1, A$, Pos& - 1))
'--- Visuel ---
A$ = Mid(A$, Pos& + 1)
Pos& = InStr(1, A$, "(")
T(5, cpt&) = Mid(A$, 1, Pos& - 1)
'--- Type ---
A$ = Mid(A$, Pos& + 1)
Pos& = InStr(1, A$, " Color ") + Len(" Color ")
A$ = Mid(A$, Pos&)
Pos& = InStrRev(A$, ": ")
T(6, cpt&) = Mid(A$, 1, Pos& - 1)
'--- Couleur ---
T(7, cpt&) = Mid(A$, Pos& + 2)
ElseIf (j& - 3) Mod 3 = 0 Then
'--- Taille ---
A$ = Trim(var(i&, j&))
Pos& = InStrRev(A$, ": ")
T(8, cpt&) = A$ 'Mid(A$, Pos& + 2)
ElseIf (j& - 4) Mod 3 = 0 Then
'--- Packaging ---
A$ = Trim(var(i&, j&))
Pos& = InStrRev(A$, ": ")
A$ = Mid(A$, Pos& + 2)
Pos& = InStr(A$, " ")
T(9, cpt&) = Mid(A$, 1, Pos& - 1)
End If
Next j&
Next i&
'--- Inscription ---
S.Cells.ClearContents
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
R.EntireColumn.AutoFit
End Sub
