Salut Kamellias,
voici ton fichier! Un petit bouton rouge à cliquer...
Dim tTabO, tTabF()
'
With Worksheets("Extract")
iRow = .Range("A" & Rows.Count).End(xlUp).Row
tTabO = .Range("A1").Resize(iRow, 5)
End With
'
For x = 1 To UBound(tTabO, 1)
If Left(CStr(tTabO(x, 2)), 4) = "VISA" Then
iIdx = iIdx + 1
ReDim Preserve tTabF(8, iIdx)
tTabF(0, iIdx) = tTabO(x, 2)
For y = x To UBound(tTabO, 1)
If CStr(tTabO(y, 1)) = "ROUTE" Then
tTabF(1, iIdx) = "TOTAL SINGLE PIECE SHIPMMENTS"
tTabF(2, iIdx) = tTabO(y + 3, 2)
tTabF(3, iIdx) = "Weight"
tTabF(4, iIdx) = "LBS"
tTabF(5, iIdx) = Trim(Split(tTabO(y + 3, 4), " ")(0))
tTabF(6, iIdx) = "KGS"
tTabF(7, iIdx) = Trim(Split(tTabO(y + 3, 4), " ")(1))
x = y + 3
Exit For
End If
Next
End If
Next
With Worksheets("Results")
.Cells.ClearContents
.Range("A2").Resize(iIdx, 8) = WorksheetFunction.Transpose(tTabF)
.Columns("A:H").AutoFit
End With
Bon travail!
A+