Discussion :

[AgentF13]

Bonsoir à tous

Je cherche à transformer une chaîne de caractères en 5 colonnes avec TextToColumns.
Les espaces avant ou après chaque découpe sont tronqués. Or je voudrai les conserver.
Y-a-t-il moyen ?

Voici mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, FieldInfo:= _
                Array(Array(0, 1), Array(158, 4), Array(168, 1), Array(1215, 1), Array(1225, 1)), _
                TrailingMinusNumbers:=True

D'avance merci

[ARTURO83]

Bonjour,

Proposition à adapter, en supposant que les textes à isoler sont en colonne A à partir de la ligne 2

le fichier en exemple
Pièce jointe 555372

le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Isoler_Les_Elements()
    Dim L As Long, a As Long, c As Long, DerLig As Long
    Dim e As Object
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For L = 2 To DerLig
        a = 1
        c = 2
        NbCarTexte = Len(Cells(L, a))
        ReDim Nb(NbCarTexte) As Long
        For i = 1 To 4
            Set e = Cells(L, a).Find(" ")
            If Not e Is Nothing Then
                 NbCar = InStr(1, Cells(L, a), " ", 1)
                Do
                   NbCar = NbCar + 1
                Loop While Mid(Cells(L, a), NbCar, 1) = " "
            End If
            Cells(L, c) = Right(Cells(L, a), Len(Cells(L, a)) - NbCar + 1)
            Nb(i) = NbCar
            c = c + 1
            a = a + 1
        Next i
        For i = 1 To 4
            Cells(L, i) = Application.WorksheetFunction.Replace(Cells(L, i), Nb(i), Len(Cells(L, i + 1)), "")
        Next i
    Next L
End Sub

Cdlt

[ARTURO83]

Petite variante à la proposition précédente, comme ça vous aurez le choix

Dans la proposition précédente, les espaces sont conservés après chaque éléments isolés, ici les espaces sont conservés devant les éléments isolés.

le fichier
Pièce jointe 555402

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub Isoler_Les_Elements()
    Dim L As Long, a As Long, c As Long, DerLig As Long
    Dim e As Object
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For L = 2 To DerLig
        a = 1
        c = 2
        NbCarTexte = Len(Cells(L, a))
        ReDim Nb(NbCarTexte) As Long
        For i = 1 To 4
            Set e = Cells(L, a).Find(" ")
            If Not e Is Nothing Then
                 NbCar = InStr(1, Cells(L, a), " ", 1)
                Do
                   NbCar = NbCar + 1
                Loop While Mid(Cells(L, a), NbCar, 1) = " "
            End If
            Cells(L, c) = Right(Cells(L, a), Len(Cells(L, a)) - NbCar + 1)
            Nb(i) = NbCar
            c = c + 1
            a = a + 1
        Next i
 
        'les espaces sont ajoutés à la suite de chaque élément
        For i = 1 To 4
            Cells(L, i) = Application.WorksheetFunction.Replace(Cells(L, i), Nb(i), Len(Cells(L, i + 1)), "")
        Next i
 
        'les espaces sont ajoutés avant chaque élément, ceux derrière les éléments sont supprimés
        For i = 4 To 1 Step -1
            Esp = Split(Cells(L, i), " ", , 1)
            Cells(L, i).Replace What:=" ", Replacement:="", LookAt:=xlPart
            Cells(L, i + 1) = Application.Rept(" ", UBound(Esp)) & Cells(L, i + 1)
        Next i
    Next L
End Sub

Cdlt

[Patrice740]

Bonjour,

Les espaces avant ou après chaque découpe sont tronqués. Or je voudrai les conserver.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, FieldInfo:= _
                Array(Array(0, 1), Array(158, 4), Array(168, 1), Array(1215, 1), Array(1225, 1)), _
                TrailingMinusNumbers:=True

Il y a une incohérence entre ta demande et la définition de FieldInfo : tu demande à Excel d'interpréter toutes les colonnes sauf la seconde au format Standard (1) et la seconde au Format Date JMA (4).
Dans ce cas il va traduire les champs. Si tu veux conserver le texte, il faut mettre tous les champs au format texte (2).

Ceci ne résoudra pas le problème de la suppression des espaces, pour ça il suffit de les remplacer un autre caractère non utilisé (ex : ¶) puis de faire l'inverse après :

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub test()
Dim r As Range
  Set r = ActiveSheet.Range("a1").CurrentRegion
  r.Replace " ", Chr(182)
  r.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, FieldInfo:= _
                Array(Array(0, 2), Array(158, 2), Array(168, 2), Array(1215, 2), Array(1225, 2))
  Set r = ActiveSheet.Range("a1").CurrentRegion
  r.Replace Chr(182), " "
End Sub