[Résolut]Séparer cellule unique par séparateur spécial (multiple)

[Triseaux]

Bonjour,

Je cherche à séparer des cellules unique comportant un caractère spécial en plusieurs cellules sur plusieurs colonnes et les coller sur d'autre colonnes ou lignes.

Un exemple
A1= truc / muche

Donne
A2 = Truc B2 = Muche

C'est simple, mais appliquer ça en macro à 2000 colonnes je n'y arrive pas, je bloque sur ma boucle, elle m’écrase toujours la même colonnes.

    Dim i As Byte
    For i = 1 To 2000
    Columns(i).TextToColumns Destination:=Range("A6"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    Next i

Si j'essaie de modifier mon Range("") j'ai des erreurs.

Un petit coup de pouce ne serais pas de refus.

 

[Hieu]

Salut,

Ci-joint un test sur 2 lignes :

For i = 1 To 2
    Range("a" & i).TextToColumns Destination:=Range("b" & i), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Next i

 

[zebanx]

Bonsoir Triseaux et bienvenu sur E.D.
Bonsoir Hieu

Un fichier qui fonctionne par ligne avec 2 macros :
1. clear contents sur les colonnes suivantes
2. la macro pour séparer les valeurs suivant le séparateur que tu rentres sur l'inputbox

A toi de mettre tous tes textes sur la première colonne

cdlt
thierry

 

[Triseaux]

Merci pour le coup de main j'ai adapter pour chopper plusieurs colonnes en même temps mais c'est ce que je voulais.

Me reste un petit bug (avec la solution de Hieu), si j'ai une case de vide il me dit "La méthode TextToColumns de la classe range a échoué"

Je n'ai pas utiliser ta solution Zebanx car je n'arriver pas à prendre plusieurs colonne en même temps en modifiant ta macro.

 

[Hieu]

Salut,

Ajoute simplement une condition :

For i = 1 To 2
if Not IsEmpty(Range("a" & i)) then
    Range("a" & i).TextToColumns Destination:=Range("b" & i), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End If
Next i

 

[Triseaux]

Salut,

Ajoute simplement une condition :

For i = 1 To 2
if Not IsEmpty(Range("a" & i)) then
    Range("a" & i).TextToColumns Destination:=Range("b" & i), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End If
Next i

Merci de l'aide, mais j'ai toujours la même erreur si j'ai une case vide.

 

[Efgé]

Bonjour à tous, le fil, le forum

Pourquoi pas :

Sub test()
Dim i&, j&
Dim Rng As Range
Dim TTmp As Variant, TReport As Variant

With Sheets("Feuil1") ' a dapter
    Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3))
End With

TReport = Rng

For i = LBound(TReport, 1) To UBound(TReport, 1)
    TTmp = Split(TReport(i, 1), "/")
    If UBound(TTmp) + 1 > UBound(TReport, 2) Then _
        ReDim Preserve TReport(1 To UBound(TReport, 1), 1 To UBound(TTmp) + 1)
    For j = LBound(TTmp) To UBound(TTmp)
        TReport(i, j + 1) = Trim(TTmp(j))
    Next j
Next i

Rng.Resize(UBound(TReport, 1), UBound(TReport, 2)) = TReport

End Sub

Cordialement

 

[Hieu]

Essaie ça :

if Not Range("a" & i)="" then
...

Je le fais à l'aveuglette, disons. Un fichier exemple, serait le bienvenu!!

 

[Triseaux]

Essaie ça :

if Not Range("a" & i)="" then
...

Je le fais à l'aveuglette, disons. Un fichier exemple, serait le bienvenu!!

c'est nickel ça fonctionne.

Merci beaucoup à vous tous et toutes