Excel VBA TextToColumns

Version imprimable

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:

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

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:

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

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:

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

Bonjour,
Citation:
Envoyé par AgentF13
Les espaces avant ou après chaque découpe sont tronqués. Or je voudrai les conserver.
Code:

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:

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