Sub SplitCell()
Dim c As Range
Dim ar
Dim i As Integer, j
Application.ScreenUpdating = False
With CreateObject("vbscript.regexp")
.Pattern = "(.{30})"
.IgnoreCase = True
.Global = True
For Each c In Selection
ar = Split(c.Value, ".")
For i = 0 To UBound(ar) - 1
ar(i) = LTrim(ar(i) & "." & vbCrLf)
ar(i) = .Replace(ar(i), "$1" & vbCrLf)
Next i
c.Offset(1, 0) = Join(ar)
Next c
End With
Application.ScreenUpdating = True
End SubSub SplitCell()
Dim c As Range
Dim ar
Dim i As Integer, j
Application.ScreenUpdating = False
With CreateObject("vbscript.regexp")
.Pattern = "(.{30})"
.IgnoreCase = True
.Global = True
For Each c In Selection
ar = Split(c.Value, ". ")
For i = 0 To UBound(ar) - 1
ar(i) = LTrim(ar(i) & "." & vbCrLf)
ar(i) = .Replace(ar(i), "$1" & vbCrLf)
ar(i) = Replace(ar(i), vbCrLf & " ", vbCrLf)
Next i
c.Offset(1, 0) = Join(ar, "")
Next c
End With
Application.ScreenUpdating = True
End Sub
Sub DecoupeSelection()
Dim xcell As Range
For Each xcell In Selection
xcell.Value = decoupe(xcell.Value, 30)
xcell.WrapText = True
xcell.EntireRow.AutoFit
Next xcell
End Sub
Function decoupe$(x, nCar)
Dim si$, sf$, k&, n&, c$, wasVbcr
si = x
n = 1
k = 0
Do
If n > Len(si) Then Exit Do
c = Mid$(si, n, 1)
n = n + 1
Select Case c
Case vbCr
sf = sf & vbCrLf
wasVbcr = True
k = 0
Case vbLf
If wasVbcr Then
wasVbcr = False
k = 0
Else
sf = sf & vbCrLf
wasVbcr = False
k = 0
End If
Case "."
sf = sf & "." & vbCrLf
wasVbcr = False
k = 0
Case Else
sf = sf & c
wasVbcr = False
k = k + 1
End Select
If k = nCar Then
sf = sf & vbCrLf
k = 0
End If
Loop
decoupe = sf
End Function.Pattern = "([^\.\r\n]{30}|.+[\.\r|\n])"Bonjour tout le monde;
Est-il possible d'avoir la phrase dans des cellules différentes ?
Merci
Sub SplitCell2()
Dim c As Range
Dim ar
Dim i As Integer
Application.ScreenUpdating = False
With CreateObject("vbscript.regexp")
.Pattern = "(.{30})"
.IgnoreCase = True
.Global = True
For Each c In Selection
ar = Split(c.Value, ". ")
For i = 0 To UBound(ar)
ar(i) = LTrim(ar(i) & "." & vbCrLf)
ar(i) = Replace(.Replace(ar(i), "$1" & vbCrLf), vbCrLf & " ", vbCrLf)
Next i
ar = Split(Join(ar, ""), vbCrLf)
c.Offset(1, 0).Resize(UBound(ar, 1)) = Application.Transpose(ar)
Next c
End With
Application.ScreenUpdating = True
End SubFunction DiviseCell(rg As Range, NbCar As Integer) As Variant
Dim c As Range
Dim ar
Dim i As Integer
Application.ScreenUpdating = False
With CreateObject("vbscript.regexp")
.Pattern = "(.{" & NbCar & "})"
.IgnoreCase = True
.Global = True
ar = Split(rg, ". ")
For i = 0 To UBound(ar)
ar(i) = LTrim(ar(i) & "." & vbCrLf)
ar(i) = Replace(.Replace(ar(i), "$1" & vbCrLf), vbCrLf & " ", vbCrLf)
Next i
ar = Split(Join(ar, ""), vbCrLf)
End With
If Application.Caller.Rows.Count > 1 Then
DiviseCell = Application.Transpose(ar)
Else
DiviseCell = ar
End If
Application.ScreenUpdating = True
End FunctionTu as compris comment l'utiliser et c'est le plus important !
Sub Decoupe()
Dim Ma_chaine As String
Dim Mon_RegExp As Object
Dim Toutes_mes_correspondances As Object
Dim Chaque_correspondance As Object
Ma_chaine = Cells(1, 1).Text
Set Mon_RegExp = CreateObject("vbscript.regexp")
With Mon_RegExp
.Global = True
.Pattern = "([^\.\r\n]{30}|.+\.|.+\r|.+\n)"
If .Test(Ma_chaine) = True Then 'teste si au moins une correspondance correspond au pattern
Set Toutes_mes_correspondances = .Execute(Ma_chaine) 'renvoie un tableau des correspondances
For Each Chaque_correspondance In Toutes_mes_correspondances
MsgBox Chaque_correspondance.Value 'renvoie chaque correspondance
Next
Else
MsgBox "Aucune correspondance trouvée"
End If
End With
Set Mon_RegExp = Nothing
Set Toutes_mes_correspondances = Nothing
Set Chaque_correspondance = Nothing
End SubSet Toutes_mes_correspondances = .Execute(Ma_chaine)Pattern = "([^\.\r\n]{30}|[^\.\r\n]{1,29}$|(.+?)\.|(.+?)\r|(.+?)\n)"Pattern = "([^\.\r\n]{30}|[^\.\r\n]{1,29}$|(.+?)\.|(.+?)\r|(.+?)\n)"(possibilité 1|possibilité 2|possibilité 3|possibilité 4|possibilité 5)[^\.\r\n]{30}[^\.\r\n]{1,29}(.+?)\.(.+?)\r(.+?)\r
