Splitting text in cells.

Saighead

New Member
Joined
May 17, 2013
Messages
34
Hi,

I need a script that would break up a block of text in a cell at full stops, question marks, and exclamation marks, and create additional cells (not rows) shifting bottom cells down and inserting split sentences consecutively into created cells.

So, for example,

A1 Sentence 1. Sentence 2? Sentence 3!
A2 Sentence 4.

Soulld become:

A1 Sentence 1.
A2 Sentence 2?
A3 Sentence 3!
A4 Sentence 4.

Could someone help me with this, please?

Thanks in advance.
 
Last edited:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Try this for results starting "C1"
Code:
[COLOR="Navy"]Sub[/COLOR] MG26Jun16
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, sp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] P [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count * 10)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    P = 1
    [COLOR="Navy"]For[/COLOR] n = 1 To Len(Dn.Value)
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Mid(Dn.Value, n, 1)
            [COLOR="Navy"]Case[/COLOR] ".": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
            [COLOR="Navy"]Case[/COLOR] "?": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
            [COLOR="Navy"]Case[/COLOR] "!": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
        [COLOR="Navy"]End[/COLOR] Select
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
Range("C1").Resize(c).Value = Application.Transpose(Ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks for the effort but this code does only a small portion of what I need (see my original example). I need split sentences to stay in the same column (with the first segment remaining in the original cell), additional cells created, existing cells shifted down, the whole shebang...
 
Upvote 0
If you are referring to My code !!!, then , by changing the results cell (at bottom of code) "C1" to "A1", and based on your data you hold get what you want
 
Upvote 0
If you are referring to My code !!!, then , by changing the results cell (at bottom of code) "C1" to "A1", and based on your data you hold get what you want

You're right, that did it. Could you modify the code so that it's not hardwired to A1 but works on any cell that has focus?
 
Upvote 0
The sub reads from A!

Code:
Function MultiCritSplit(InString As String, Crit1 As String, Optional Crit2 As String, Optional Crit3 As String, Optional Crit4 As String, Optional Crit5 As String) As String()
Dim TmpString As String
Dim CritArray() As String
Dim OutArray() As String
Dim MidString As String
Dim ArrayCnt As Integer
Dim LenInString As Integer
Dim CharCnt As Integer
Dim ChkLoop As Integer
Dim ArrayID As Integer
Dim x As Integer
ArrayCnt = 0


' Validate
If Trim(Crit1) = "" Or Trim(InString) = "" Then
    GoTo NoCrit
Else
    ReDim CritArray(ArrayCnt)
    CritArray(ArrayCnt) = Crit1
End If
 
If IsMissing(Crit2) = False Then
    ArrayCnt = ArrayCnt + 1
    ReDim Preserve CritArray(ArrayCnt)
    CritArray(ArrayCnt) = Crit2
End If


If IsMissing(Crit3) = False Then
    ArrayCnt = ArrayCnt + 1
    ReDim Preserve CritArray(ArrayCnt)
    CritArray(ArrayCnt) = Crit3
End If


If IsMissing(Crit4) = False Then
    ArrayCnt = ArrayCnt + 1
    ReDim Preserve CritArray(ArrayCnt)
    CritArray(ArrayCnt) = Crit4
End If


If IsMissing(Crit5) = False Then
    ArrayCnt = ArrayCnt + 1
    ReDim Preserve CritArray(ArrayCnt)
    CritArray(ArrayCnt) = Crit5
End If


' Split input string
ArrayID = 0
TmpString = InString
LenInString = Len(TmpString)
CharCnt = 1
x = 1
Do While LenInString > 0 And x < 10000
    For ChkLoop = 0 To ArrayCnt
        MidString = Mid(TmpString, CharCnt, 1)
        If MidString = CritArray(ChkLoop) Then
            ReDim Preserve OutArray(ArrayID)
            OutArray(ArrayID) = Mid(TmpString, 1, CharCnt - 1)
            TmpString = Right(TmpString, LenInString - CharCnt)
            LenInString = Len(TmpString)
            ArrayID = ArrayID + 1
            CharCnt = 1
            Exit For
        End If
    Next ChkLoop
    CharCnt = CharCnt + 1
    x = x + 1
Loop


MultiCritSplit = OutArray
Exit Function


NoCrit:


End Function




Sub TestSplit()
Dim RplyArray() As String
Dim LbRArray As Integer
Dim UbRArray As Integer
Dim Rloop As Integer




RplyArray = MultiCritSplit(Range("A1").Value, ",", "?", ".", ";", "!")
LbRArray = LBound(RplyArray)
UbRArray = UBound(RplyArray)


For Rloop = LbRArray To UbRArray
    Range("A" & 3 + Rloop).Value = RplyArray(Rloop)
Next Rloop


End Sub
 
Upvote 0
Try this:-
NB:- The code now Requires yo to select a range of cells.
Code:
[COLOR="Navy"]Sub[/COLOR] MG26Jun31
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] P [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Selection
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]Next[/COLOR] Dn
ReDim Ray(1 To Rng.Count * 10)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    P = 1
    [COLOR="Navy"]For[/COLOR] n = 1 To Len(Dn.Value)
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Mid(Dn.Value, n, 1)
            [COLOR="Navy"]Case[/COLOR] ".": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
            [COLOR="Navy"]Case[/COLOR] "?": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
            [COLOR="Navy"]Case[/COLOR] "!": c = c + 1: Ray(c) = Mid(Dn.Value, P, n - P + 1): P = n + 2
        [COLOR="Navy"]End[/COLOR] Select
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
Rng(1).Resize(c).Value = Application.Transpose(Ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG

This modified code overwrites cells below.

Your initial code loses segments after the last separator (if A1 has "Sentence 1. Sentence 2? Sentence 3! Sentence 4 (no punctuation here)", then Sentence 4 is lost). Also it overwrites cells below instead of shifting them down if they do not end in a separator (.?!), and splits them at separators even when they are not in focus (again losing segments after the last separator)...
 
Last edited:
Upvote 0
Cross post https://www.excelforum.com/excel-programming-vba-macros/1235740-splitting-text-in-cells.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,952
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top