Splitting text in cells.

[Saighead]

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.

 

[Rick Rothstein]

First, make sure you read what Fluff posted in Message #10 .

With that said, see if this macro does what you want. First, select the cells whose sentences you want to list in individual cells, then run this macro...

[table="width: 500"]
[tr]
	[td]Sub SplitSelectedSentenceCellsDown()
  Dim Cnt As Long, Combo As String, Sentences() As String
  Cnt = Selection.Rows.Count
  Combo = Join(Application.Transpose(Selection.Value))
  Sentences = Split(Replace(Replace(Replace(Combo, ". ", "." & vbLf), "? ", "?" & vbLf), "! ", "!" & vbLf), vbLf)
  Cnt = UBound(Sentences) - Cnt
  Selection(1).Resize(Cnt).Insert xlDown
  Selection(1).Resize(UBound(Sentences)) = Application.Transpose(Sentences)
End Sub[/td]
[/tr]
[/table]

NOTE: The above code assumes that your sentences only end with a period, question mark or exclamation mark and, in addition, it assumes that there are no abbreviations ending with a period (such as Mr., Ave., No., etc.) anywhere within any of the sentences.

 

[Rick Rothstein]

First, make sure you read what Fluff posted in Message #10 .

With that said, see if this macro does what you want. First, select the cells whose sentences you want to list in individual cells, then run this macro...

[table="width: 500"]
[tr]
	[td]Sub SplitSelectedSentenceCellsDown()
  Dim Cnt As Long, Combo As String, Sentences() As String
  Cnt = Selection.Rows.Count
  Combo = Join(Application.Transpose(Selection.Value))
  Sentences = Split(Replace(Replace(Replace(Combo, ". ", "." & vbLf), "? ", "?" & vbLf), "! ", "!" & vbLf), vbLf)
  Cnt = UBound(Sentences) - Cnt
  Selection(1).Resize(Cnt).Insert xlDown
  Selection(1).Resize(UBound(Sentences)) = Application.Transpose(Sentences)
End Sub[/td]
[/tr]
[/table]

NOTE: The above code assumes that your sentences only end with a period, question mark or exclamation mark and, in addition, it assumes that there are no abbreviations ending with a period (such as Mr., Ave., No., etc.) anywhere within any of the sentences.

It occurs to me that the above code will probably fail due to the use of the Transpose function and the fact that the combined sentences will end up being longer than the what Transpose can handle. Here is revised code that should work no matter how long or how many sentences there are.

[table="width: 500"]
[tr]
	[td]Sub SplitSelectedSentenceCellsDown()
  Dim R As Long, Cnt As Long, Combo As String, Sentences As Variant, Result As Variant
  Dim Data As Variant
  Data = Selection.Value
  Cnt = Selection.Rows.Count
  For R = 1 To UBound(Data)
    Combo = Combo & " " & Data(R, 1)
  Next
  Sentences = Split(Replace(Replace(Replace(Trim(Combo), ". ", "." & vbLf), "? ", "?" & vbLf), "! ", "!" & vbLf), vbLf)
  Cnt = UBound(Sentences) - Cnt + 1
  ReDim Result(1 To UBound(Sentences), 1 To 1)
  Selection(1).Resize(Cnt).Insert xlDown
  For R = 1 To UBound(Sentences)
    Result(R, 1) = Sentences(R - 1)
  Next
  Selection(1).Resize(UBound(Result)) = Result
End Sub[/td]
[/tr]
[/table]

 

[nemmi69]

Sorry Fluff

Right, modified mine so that it now reads multiple rows in column A. If you do not need to change the word separators you could change the function so that they are fixed in it and remove the checks that they are supplied.
I tested this with

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

It writes to column E at the moment

Function MultiCritSplit(ByVal 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 ReplyRow 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
ReplyRow = 1
Do While LenInString > 0 And ReplyRow < 10000
    For ChkLoop = 0 To ArrayCnt
        MidString = Mid(TmpString, CharCnt, 1)
        If MidString = CritArray(ChkLoop) Then
            ReDim Preserve OutArray(ArrayID)
            OutArray(ArrayID) = Trim(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
    ReplyRow = ReplyRow + 1
Loop


MultiCritSplit = OutArray
Exit Function


NoCrit:


End Function

Test sub

Sub TestSplit()
Dim RplyArray() As String
Dim LbRArray As Integer
Dim UbRArray As Integer
Dim Rloop As Integer
Dim LastRowNo As Long
Dim InLoop As Long
Dim InputArray
Dim LbInArray As Long
Dim UbInArray As Long
Dim OutputArray()
Dim OutCnt As Long
Dim LbOutArray As Long
Dim UbOutArray As Long
Dim ReplyRow As Long


' Assuming 1st data is in A1
LastRowNo = Range("A65536").End(xlUp).Row
' Build new array
If LastRowNo >= 1 Then
    ReplyRow = 1
    'collect range data
    InputArray = Application.Transpose(Range("A1:A" & LastRowNo).Value)
    LbInArray = LBound(InputArray)
    UbInArray = UBound(InputArray)
    OutCnt = 0
    ' Process each row
    For InLoop = LbInArray To UbInArray
'    MsgBox InputArray(InLoop) '##test
        RplyArray = MultiCritSplit(InputArray(InLoop), ",", "?", ".", ";", "!")
        LbRArray = LBound(RplyArray)
        UbRArray = UBound(RplyArray)
        For Rloop = LbRArray To UbRArray
                Range("E" & ReplyRow).Value = RplyArray(Rloop)
                ReplyRow = ReplyRow + 1
        Next Rloop
    Next InLoop
    
End If
End Sub

 

[Rick Rothstein]

@nemmi69... just wondering if you got a chance to try the code I posted in Message #12 yet?

 

[Rick Rothstein]

@nemmi69... just wondering if you got a chance to try the code I posted in Message #12 yet?

Sorry, this question should have been to Saighead, not nemmi69.

 

[nemmi69]

Rick Rothstein

Using

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

It returned

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

 

[Rick Rothstein]

A3 Sentence 1.A3 Sentence 2? A3 Sentence 3!

Are you saying we should assume there are sentences that do not have a space separating them from the next sentence?

 

[nemmi69]

Are you saying we should assume there are sentences that do not have a space separating them from the next sentence?

I set it to "trim" so there are spaces before or after in the split data.

P.S. How do you tag someones name so you can reply to them as you did me?

 

[Rick Rothstein]

I set it to "trim" so there are spaces before or after in the split data.

I am not sure what the above means as it relates to this sentence(?) which I quoted in Message #17 ...

A3 Sentence 1.A3 Sentence 2? A3 Sentence 3!

I am not sure what the multiple A3's mean, but what I highlighted in red appears to be one sentence followed by a second sentence (highlighted in blue) without a space between them. My question was do you think the OP has that kind of sentence structure? Or, now that I think of it, were those multiple A3's meant to indicate sentence on different lines within the same cell?

P.S. How do you tag someones name so you can reply to them as you did me?

The forum seems to do that automatically when you put an @ symbol in front of the name the person uses to identify themselves with.

 

[nemmi69]

@Rick Rothstein I went on the assumption that the split is based on the supplied criteria in the case of A3 Sentence 1.A3 Sentence 2? A3 Sentence 3! it separated on "." and "?".

I just noticed that my Sub did not insert just write the reply back so that any data below the selection would be overwritten. I have now amended it to
A) Insert once the original rows have been passed
B) Allow user to select the rows with a restriction to 1 column.

Data used

A1 Sentence 1. Sentence 2? Sentence 3!
A2 Sentence 4.
A3 Sentence 1.A3 Sentence 2? A3 Sentence 3!
This data to be last

Returned data

A1 Sentence 1
Sentence 2
Sentence 3
A2 Sentence 4
A3 Sentence 1
A3 Sentence 2
A3 Sentence 3
This data to be last

Sub TestSplit()
Dim RplyArray() As String
Dim LbRArray As Integer
Dim UbRArray As Integer
Dim Rloop As Integer
Dim FirstColNo As Long
Dim FirstRowNo As Long
Dim LastRowNo As Long
Dim InLoop As Long
Dim InputArray
Dim LbInArray As Long
Dim UbInArray As Long
Dim OutputArray()
Dim OutCnt As Long
Dim LbOutArray As Long
Dim UbOutArray As Long
Dim RowInc As Long
Dim ErrData As Boolean


ErrData = False
'Check if more than 1 column selected
If Selection.Columns.Count > 1 Then
    MsgBox "Sorry, Only 1 column can be selected.", vbCritical, ThisWorkbook.Name
Else
    FirstColNo = Selection.Column
    FirstRowNo = Selection.Row
    LastRowNo = Selection.Rows.Count
    'MsgBox "1st " & FirstRowNo & " | last " & LastRowNo & " | col " & FirstColNo
    'Check if range is empty
    For Rloop = FirstRowNo To (FirstRowNo + LastRowNo - 1)
        If Trim(Cells(Rloop, FirstColNo).Value) = "" Then
            MsgBox "Sorry, row " & Rloop & " contains no string data.", vbCritical, ThisWorkbook.Name
            ErrData = True
            Exit For
        End If
    Next Rloop
    If ErrData = False Then
    ' Build new array
        RowInc = 0
        'collect range data
        InputArray = Application.Transpose(Selection.Value)
        LbInArray = LBound(InputArray)
        UbInArray = UBound(InputArray)
        OutCnt = 0
        ' Process each row
        For InLoop = LbInArray To UbInArray
    '    MsgBox InputArray(InLoop) '##test
            RplyArray = MultiCritSplit(InputArray(InLoop), ",", "?", ".", ";", "!")
            LbRArray = LBound(RplyArray)
            UbRArray = UBound(RplyArray)
            For Rloop = LbRArray To UbRArray
                    If RowInc >= LastRowNo Then
                        Cells(FirstRowNo + RowInc, FirstColNo).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    End If
                    Cells(FirstRowNo + RowInc, FirstColNo).Value = RplyArray(Rloop)
                    RowInc = RowInc + 1
            Next Rloop
        Next InLoop
    End If
End If
End Sub