Bonjour
Ci dessous une procédure qui devrait répondre au problème.
Il faut corriger le texte suivant
1 x 1096 mReste : 111 mm. La procédure utilise les "mm" comme séparateur.
1 x 1096 mm Reste : 111 mm.
A tester
Sub travdem()
Dim Cellule1 As Range, Plg1 As Range, pos As Integer, Data As String, I1 As Integer
Dim Nomfeuille1 As String, Col1 As String
'parametre
Col1 = "A"
'code
With Sheets(ActiveSheet.Name)
'réorganisation du texte
For Each Cellule1 In .Range(Col1 & "74:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
If Cellule1 <> "" Then
If InStr(1, Cellule1, "Reste") = 0 Then
Cellule1 = Cellule1 & " " & Cellule1.Offset(1, 0)
Cellule1.Offset(1, 0) = ""
End If
End If
Next Cellule1
' suppression des espaces
For Each Cellule1 In .Range(Col1 & "74:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
If Cellule1 <> "" Then
Do
If InStr(1, Cellule1, " ") > 0 Then
Cellule1 = Replace(Cellule1, " ", " ")
Else
Exit Do
End If
Loop
End If
Next Cellule1
For Each Cellule1 In .Range(Col1 & "74:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
Data = Cellule1
If Data <> "" Then
pos = InStr(1, Data, ":")
If pos > 0 Then
Cellule1.Offset(0, 5) = Trim(Mid(Data, 1, pos - 1))
Data = Trim(Mid(Data, pos + 1))
End If
I1 = 6
Do
If InStr(1, Data, "mm") > 0 Then
pos = InStr(1, Data, "mm")
Cellule1.Offset(0, I1) = Trim(Mid(Data, 1, pos + 2))
Data = Trim(Mid(Data, pos + 2))
I1 = I1 + 1
Else
Exit Do
End If
Loop
End If
Next Cellule1
End With
End Sub
Bonne journée
JP14