Divide the cell content into separate rows in Exce

Question

I am trying to split the cell content with length greater than 72 into separate rows with their length not increasing more than 72 chars. I am not able to thing through this logic and need help. Special challenge here is that the content of each cell is is a complete sentence and has no delimiter, so I need to divide the statement only when a word ends and also having length 72 chars preserved for each cell and not more than that.

Any suggestions?

Thanks

Answer 1

You can do this using regular expressions. Try adapting this macro, which I wrote some time ago, to your specific requirements: If a word should happen to be longer than w characters, it will overflow -- probably not a problem with 72 character line length; but you can change that behavior by changing the regex.

As written, the macro will write the split text into cells below the original.

---

Sub WordWrap()
'requires reference to Microsoft VBScript Regular Expressions 5.5
'Wraps at W characters, but will allow overflow if a word is longer than W
Dim RE As RegExp, MC As MatchCollection, m As Match
Dim str As String
Dim w As Long
Dim rSrc As Range, C As Range
Dim mBox As Long
Dim I As Long
'with offset as 1, split data will be below original data
'with offset = 0, split data will replace original data
Const lDestOffset As Long = 1

Set rSrc = Selection
    If rSrc.Rows.Count <> 1 Then
        MsgBox ("You may only select" & vbLf & " Data in One (1) Row")
        Exit Sub
    End If
Set RE = New RegExp
    RE.Global = True
w = InputBox("Maximum characters in a Line: ", , 72)
    If w < 1 Then w = 79
For Each C In rSrc
str = C.Value
'remove all line feeds and nbsp
    RE.Pattern = "[\xA0\r\n\s]+"
    str = RE.Replace(str, " ")
    RE.Pattern = "\S.{0," & w - 1 & "}(?=\s|$)|\S{" & w & ",}"
If RE.Test(str) = True Then
    Set MC = RE.Execute(str)
'see if there is enough room
I = lDestOffset + 1
Do Until I > MC.Count + lDestOffset
    If Len(C(I, 1)) <> 0 Then
        mBox = MsgBox("Data in " & C(I, 1).Address & " will be erased if you contine", vbOKCancel)
        If mBox = vbCancel Then Exit Sub
    End If
I = I + 1
Loop

    I = lDestOffset
    For Each m In MC
        C.Offset(I, 0).Value = m
        I = I + 1
    Next m
End If
Next C
Set RE = Nothing
End Sub

---

Example using your original post as the data in one cell:

Here is an explanation and links to explanations regarding the line-splitting regular expression, as it would be rendered with a line length of 72 characters.

\S.{0,71}(?=\s|$)|\S{72,}

\S.{0,71}(?=\s|$)|\S{72,}

Options: Case sensitive; ^$ match at line breaks (irrelevant in this instance)

• Match this alternative \S.{0,71}(?=\s|$)
  • Match a single character that is NOT a “whitespace character” \S
  • Match any single character that is NOT a line break character .{0,71}
    • Between zero and 71 times, as many times as possible, giving back as needed (greedy) {0,71}
  • Assert that the regex below can be matched, starting at this position (positive lookahead) (?=\s|$)
    • Match this alternative \s
      • Match a single character that is a “whitespace character” \s
    • Or match this alternative $
      • Assert position at the end of a line $
• Or match this alternative \S{72,}
  • Match a single character that is NOT a “whitespace character” \S{72,}
    • Between 72 and unlimited times, as many times as possible, giving back as needed (greedy) {72,}

Created with RegexBuddy

EDIT At the request of the original poster, a routine was added which would cycle through the cells in column A, placing the results of the splitting into column B. Some of the original code, allowing selection of line length and source selection, was hard-coded.

---

Option Explicit
Sub WordWrap2()
'requires reference to Microsoft VBScript Regular Expressions 5.5
'Wraps at W characters, but will allow overflow if a word is longer than W
Dim RE As RegExp, MC As MatchCollection, M As Match
Dim str As String
Const W As Long = 72
Dim rSrc As Range, C As Range
Dim vRes() As Variant
Dim I As Long

'Set source to column A
Set rSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp))

Set RE = New RegExp
    RE.Global = True
    I = 0
    For Each C In rSrc
    str = C.Value

    'remove all line feeds and nbsp
    RE.Pattern = "[\xA0\r\n\s]+"
    str = RE.Replace(str, " ")
    RE.Pattern = "\S.{0," & W - 1 & "}(?=\s|$)|\S{" & W & ",}"

    If RE.Test(str) = True Then
        Set MC = RE.Execute(str)
        ReDim Preserve vRes(1 To MC.Count + I)
        For Each M In MC
            I = I + 1
            vRes(I) = M
        Next M
        Else  'Allow preservation of blank lines in source data
         I = I + 1
    End If
Next C

'if ubound(vres) > 16384 then will need to transpose in a loop
vRes = WorksheetFunction.Transpose(vRes)

With Range("B1").Resize(UBound(vRes, 1))
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

Set RE = Nothing
End Sub

---

Answer 2

How about this:

Sub Demo()
    Dim str As String
    Dim i As Long, rowIdx As Long
    Dim myString As Variant
    str = " "
    myString = Split(Range("A1").Value)
    rowIdx = 5    '-->row number from where data will be displayed
    For i = LBound(myString) To UBound(myString)
        If (Len(str) + Len(myString(i)) + 1) > 72 Then '-->check for length > 72
            Range("A" & rowIdx).Value = Trim(str)      '-->if > 72 display in cell
            rowIdx = rowIdx + 1                        '-->increment row index
            str = ""                 'set str="" to countinue for new line
        End If
        str = str & myString(i) & " "
    Next
    If Len(str) > 0 Then Range("A" & rowIdx).Value = Trim(str) 'display remiaing words
End Sub