Splitting text in cells.

Saighead

New Member
Joined
May 17, 2013
Messages
33
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:

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 

Saighead

New Member
Joined
May 17, 2013
Messages
33
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...
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841

ADVERTISEMENT

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
 

Saighead

New Member
Joined
May 17, 2013
Messages
33
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?
 

nemmi69

Active Member
Joined
Mar 15, 2012
Messages
482
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows

ADVERTISEMENT

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
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 

Saighead

New Member
Joined
May 17, 2013
Messages
33
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:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,727
Office Version
  1. 365
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,168
Messages
5,594,632
Members
413,919
Latest member
ZaxAlchemist

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
Top