Pb SPLIT avec deux séparateurs ( array ("+", "-")

zebanx · 12 Octobre 2018

Bonjour à tous,

Je cherche à spliter sur plusieurs colonnes certaines cellules liées.
Un code me permet de le faire en utilisant SPLIT avec comme séparateur "+".

Mais je souhaite utiliser un deuxième séparateur "-" dans le tableau.
Tentative avec un array mais ça ne fonctionne pas du tout.

Un classeur d'accompagnement reprend plus clairement le besoin. Attention, il faut sélectionner la zone avant de lancer la macro.

Pourriez-vous m'aider svp à corriger le code initial (séparateur uniquement "+") suivant :

Code:

Sub splitSelection_plus()
Dim k As Integer
Dim selR As Range

Set selR = Selection
With Selection
lignedeb = .Row
colref = .Column
lignefin = lignedeb + .Rows.Count - 1
End With

separ = "+"

On Error Resume Next
For k = lignedeb To lignefin + 1
    For l = 0 To 9
        If Mid(Cells(k, colref), 2, 1) = separ Then
        Cells(k, colref).Offset(0, l + 1).Formula = "=" & Split(Cells(k, colref), separ)(l + 1) '---va chercher valeur
        Else
        Cells(k, colref).Offset(0, l + 1).Formula = IIf(l = 0, Split(Cells(k, colref), separ)(l), "=" & Split(Cells(k, colref), separ)(l))
       End If
     Next l
Next k

End Sub

Je vous en remercie
zebanx

zebanx · 12 Octobre 2018

Je crois avoir pu contourné le problème en remplaçant le "-" par un "+-" qui permet de n'utiliser qu'un caractère. Bien pratique.
Un "-", c'est un "+-" qui s'ignore.

Désolé pour le dérangement, bonne journée
++

Code:

Sub splitSelection_plus_moins()
Dim k As Integer
Dim selR As Range

Set selR = Selection
separ = "+"
With Selection
lignedeb = .Row: colref = .Column: lignefin = lignedeb + .Rows.Count - 1
.replace What:="-", Replacement:="+-", LookAt:=xlPart, SearchOrder:=xlByRows
End With

On Error Resume Next
For k = lignedeb To lignefin + 1
    For l = 0 To 9
        If Mid(Cells(k, colref), 2, 1) = separ Then
        Cells(k, colref).Offset(0, l + 1).Formula = "=" & Split(Cells(k, colref), separ)(l + 1) '---va chercher valeur
        Else
        Cells(k, colref).Offset(0, l + 1).Formula = IIf(l = 0, Split(Cells(k, colref), separ)(l), "=" & Split(Cells(k, colref), separ)(l))
       End If
     Next l
Next k

End Sub

BOISGONTIER · 12 Octobre 2018

Bonjour,

Une fonction SplitPlusMoins(chaine) ??

Code:

Sub Essai2()
  chaine = "aa+bb-cc+dd"
  Tbl = SplitPlusMoins(chaine)
  [A1].Resize(UBound(Tbl) + 1) = Application.Transpose(Tbl)
End Sub

Function SplitPlusMoins(chaine)
  SplitPlusMoins = Split(Replace(chaine, "-", "+"), "+")
End Function

Boisgontier

Dranreb · 12 Octobre 2018

Bonjour.
Comme ça ça a l'air pas mal :

VB:

Sub SplitPlusMoins()
Dim TE(), L&, TS(), C&, Ts1$(), P1&, Ts2$(), P2&
TE = Selection.Value
ReDim TS(1 To UBound(TE, 1), 1 To 6)
For L = 1 To UBound(TE, 1)
   C = 0: Ts1 = Split(Mid$(TE(L, 1), 2), "+")
   For P1 = 0 To UBound(Ts1)
      Ts2 = Split(Ts1(P1), "-"): If UBound(Ts2) < 0 Then ReDim Ts2(0 To 0)
      C = C + 1: If Ts2(0) <> "" Then TS(L, C) = "=" & Ts2(0)
      For P2 = 1 To UBound(Ts2)
         C = C + 1: If Ts2(P2) <> "" Then TS(L, C) = "=-" & Ts2(P2)
         Next P2, P1, L
Selection.Columns(2).Resize(, 6).Value = TS
End Sub

Dranreb · 12 Octobre 2018

Ou plutôt comme ça, si un "+" au début ni des séries de séparateurs consécutifs n'ont de signification :

VB:

Sub SplitPlusMoins()
Dim TE(), L&, TS(), C&, Ts1$(), P1&, Ts2$(), P2&
TE = Selection.Value
ReDim TS(1 To UBound(TE, 1), 1 To 6)
For L = 1 To UBound(TE, 1)
   C = 0: Ts1 = Split(Mid$(TE(L, 1), 2), "+")
   For P1 = 0 To UBound(Ts1)
      Ts2 = Split(Ts1(P1), "-"): If UBound(Ts2) < 0 Then ReDim Ts2(0 To 0)
      If Ts2(0) <> "" Then C = C + 1: TS(L, C) = "=" & Ts2(0)
      For P2 = 1 To UBound(Ts2)
         If Ts2(P2) <> "" Then C = C + 1: TS(L, C) = "=-" & Ts2(P2)
         Next P2, P1, L
Selection.Columns(2).Resize(, 6).Value = TS
End Sub

job75 · 12 Octobre 2018

Bonjour zebanx, JB, Bernard,

Code:

Sub split_plus_moins()
Dim c As Range, s, n%, i%, x As Variant
Application.ScreenUpdating = False
With Feuil1.[A1].CurrentRegion.Columns(1)
    .Offset(, 1).Resize(, .Parent.Columns.Count - 1).ClearContents 'RAZ
    For Each c In .Cells
        s = Split(Replace(c, "-", "+-"), "+")
        n = 1
        For i = 0 To UBound(s)
            x = Evaluate(s(i))
            If Not IsError(x) Then
                n = n + 1
                c(1, n) = x
            End If
    Next i, c
End With
End Sub

S'il y a beaucoup de lignes il faudra utiliser des tableaux VBA.

A+

ChTi160 · 12 Octobre 2018

Bonjour
Bonjour le Fil ,le Forum
Edit effectivement pas compris lol
jean marie

zebanx · 12 Octobre 2018

Bonjour et merci à tous pour vos réponses.

Je dois préciser que l'utilité est double, ce qui aurait dû être indiqué dès le départ :

1- Éclater pour ce qu'on appelle une "piste d'audit" une formule utilisée dans un tableau avec ses différentes composantes

2- Prévoir automatiquement un lien hypertexte (sujet de cette fin de semaine..).
Pour le point 2, la deuxième solution de Dranreb me convient peut-être la mieux car elle préserve les formules.

Le travail est fait et je vous en remercie.

Et pour les syntaxes, l'utilisation des différentes méthodes reste vraiment très intéressante, comme d'habitude.

Bon apm
zebanx

job75 · 12 Octobre 2018

Re,

job75 à dit:
S'il y a beaucoup de lignes il faudra utiliser des tableaux VBA.

Sur 10 000 lignes cette macro s'exécute chez moi en 9,5 secondes :

Code:

Sub split_plus_moins()
Dim t, tablo, i&, s, n%, j%, x As Variant, ncol%, resu()
t = Timer
With Feuil1.[A1].CurrentRegion.Columns(1)
    tablo = .Resize(.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo) - 1
        s = Split(Replace(tablo(i, 1), "-", "+-"), "+")
        n = 0
        For j = 0 To UBound(s)
            x = Evaluate(s(j))
            If Not IsError(x) Then
                n = n + 1
                If n > ncol Then ncol = n: ReDim Preserve resu(1 To UBound(tablo), 1 To n)
                resu(i, n) = x
            End If
    Next j, i
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Offset(, 1).Resize(, ncol) = resu
    .Offset(, ncol + 1).Resize(, .Parent.Columns.Count - ncol - 1).ClearContents 'RAZ à droite
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Fichier (2).

A+

zebanx · 12 Octobre 2018

Merci à Job75

En rajoutant un application.calculation, ta macro s'exécute plus rapidement en 4 secondes
Avec la macro en 2, on tourne autour des 6 secondes mais elle modifie la colonne 1 "remplacement de "-" par "+-" ce qui pose problème pour une relance de la macro).
Mais celle de Dranreb en #5 tourne en moins de 1 seconde.
Je zippe le tout, trop lourd.
Par contre, il faut toujours sélectionner les zones avec les macros ...zebanx ou ....dranreb à ce stade (mais ça je l'avais pas demandé..)

@+

Code:

Sub split_plus_moins()
Dim t, tablo, i&, s, n%, j%, x As Variant, ncol%, resu()
t = Timer
Application.Calculation = xlManual
With Feuil1.[A1].CurrentRegion.Columns(1)
    tablo = .Resize(.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo) - 1
        s = Split(Replace(tablo(i, 1), "-", "+-"), "+")
        n = 0
        For j = 0 To UBound(s)
            x = Evaluate(s(j))
            If Not IsError(x) Then
                n = n + 1
                If n > ncol Then ncol = n: ReDim Preserve resu(1 To UBound(tablo), 1 To n)
                resu(i, n) = x
            End If
    Next j, i
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Offset(, 1).Resize(, ncol) = resu
    .Offset(, ncol + 1).Resize(, .Parent.Columns.Count - ncol - 1).ClearContents 'RAZ à droite
End With
Application.Calculation = xlAutomatic
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

job75 · 12 Octobre 2018

Re,

zebanx à dit:
2- Prévoir automatiquement un lien hypertexte (sujet de cette fin de semaine..).

Chez moi sur 10 000 lignes les liens hypertextes sont créés en 24 secondes :

Code:

Sub split_plus_moins()
Dim t, c As Range, s, n%, i%, x$, e As Variant
t = Timer
Application.ScreenUpdating = False
With Feuil1.[A1].CurrentRegion.Columns(1)
    .Offset(, 1).Resize(, .Parent.Columns.Count - 1).Delete xlToLeft 'RAZ
    For Each c In .Cells
        s = Split(Replace(Replace(c.Formula, "=", ""), "-", "+-"), "+")
        n = 1
        For i = 0 To UBound(s)
            x = s(i): e = Evaluate(x)
            If Not IsError(e) Then
                n = n + 1
                c(1, n).Hyperlinks.Add c(1, n), "", "#" & Replace(x, "-", ""), TextToDisplay:=CStr(e)
            End If
    Next i, c
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Fichier (3).

A+

zebanx · 12 Octobre 2018

Très très beau travail, merci JOB75

Le temps me convient très bien et ton extraction permet de lier les nombres négatifs à la cellule liée, c'est super.
Ca fait un très joli code pour quelqu'un qui doit utiliser des nombreux liens pour aller directement à sa source. Et il n'y a surement pas 10000 lignes donc ton code va aller impeccable.
Sur 1000 lignes, moins d'une seconde, c'est déjà une bonne base !

Serait-il possible cependant STP d'avoir un autre code permettant d'afficher dans la barre de formule, pour chaque cellule "splitée", la cellule liée ?
---> si c'est trop long à faire, ne le fait pas, y a pas de problème, c'est déjà beaucoup !

Et quand tu auras le temps stp, pourrais-tu me donner quelques précisions sur les parties en "rouge" :
- s = Split(Replace(Replace(c.Formula, "=", ""), "-", "+-"), "+")
- c(1, n).Hyperlinks.Add c(1, n), "", "#" & Replace(x, "-", ""), TextToDisplay:=CStr(e)

Je te remerie vivement pour ce post et te souhaite une bonne soirée
zebanx

job75 · 12 Octobre 2018

Re,

Replace(c.Formula, "=", "") supprime le signe "=".

c(1, n), "", "#" & Replace(x, "-", "") => cellule de l'ancrage, adresse (""), sous-adresse (feuille du fichier).

A+

job75 · 12 Octobre 2018

Re,

zebanx à dit:
Serait-il possible cependant STP d'avoir un autre code permettant d'afficher dans la barre de formule, pour chaque cellule "splitée", la cellule liée ?

Fichier (4) avec cette macro :

Code:

Sub split_plus_moins()
Dim t, c As Range, s, n%, i%, x$, e As Variant
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Feuil1.[A1].CurrentRegion.Columns(1)
    .Offset(, 1).Resize(, .Parent.Columns.Count - 1).Delete xlToLeft 'RAZ
    For Each c In .Cells
        s = Split(Replace(Replace(c.Formula, "=", ""), "-", "+-"), "+")
        n = 1
        For i = 0 To UBound(s)
            x = s(i): e = Evaluate(x)
            If Not IsError(e) Then
                n = n + 1
                c(1, n) = "=" & x
                c(1, n).Hyperlinks.Add c(1, n), "", "#" & Replace(x, "-", "")
            End If
    Next i, c
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Chez moi, grâce aux Application.Calculation, la durée d'exécution augmente peu => 26 secondes.

A+

Pb SPLIT avec deux séparateurs ( array ("+", "-")

zebanx

XLDnaute Accro

Pièces jointes

zebanx

XLDnaute Accro

BOISGONTIER

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

ChTi160

XLDnaute Barbatruc

zebanx

XLDnaute Accro

job75

XLDnaute Barbatruc

Pièces jointes

zebanx

XLDnaute Accro

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

zebanx

XLDnaute Accro

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires