I have a spreadsheet full of data. In column "H" I have cells upon cells of between 3-7 paragraphs. Ideally I would like to split the cell into 2 paragraph max length cells and merge the remaining paragraphs down with that same rule. I have working VBA that will do this every paragraph. End goal is to instead do this every "x" paragraphs (ideally "2" paragraphs) for cells that contain lots of text. Thanks for any pointers!
I did take a brief dive into split string based on character count, but my attempts messed with paragraph ends. Also a problem with the below code is that it splits a cell every "Enter" key or new line vs after two paragraphs.
Sub splitcells()
Dim InxSplit As Long
Dim SplitCell() As String
Dim RowCrnt As Long
With Worksheets("Sheet1")
RowCrnt = 10 ' The first row containing data.
Do While True
' * I use .Cells(row, column) rather than .Range because it is more
' convenient when you need to change the row and/or column numbers.
' * Note the column value can be a number or a column identifier.
' A = 1, B=2, Z=26, AA = 27, etc. I am not doing arithmetic with
' the columns so I have used "A" and "B" which I find more
' meaningful than 1 and 2.
If .Cells(RowCrnt, "H").Value = "" Then
Exit Do
End If
SplitCell = Split(.Cells(RowCrnt, "H").Value, Chr(10))
If UBound(SplitCell) > 0 Then
' The cell contained a line break so this row is to be spread across
' two or more rows.
' Update the current row
.Cells(RowCrnt, "H").Value = SplitCell(0)
' For each subsequent element of the split value, insert a row
' and place the appropriate values within it.
For InxSplit = 1 To UBound(SplitCell)
RowCrnt = RowCrnt + 1
' Push the rest of the worksheet down
.Rows(RowCrnt).EntireRow.Insert
' Select the appropriate part of the original cell for this row
.Cells(RowCrnt, "H").Value = SplitCell(InxSplit)
' Copy the value from column B from the previous row
.Cells(RowCrnt, "A").Value = .Cells(RowCrnt - 1, "A").Value
.Cells(RowCrnt, "B").Value = .Cells(RowCrnt - 1, "B").Value
.Cells(RowCrnt, "C").Value = .Cells(RowCrnt - 1, "C").Value
.Cells(RowCrnt, "D").Value = .Cells(RowCrnt - 1, "D").Value
.Cells(RowCrnt, "E").Value = .Cells(RowCrnt - 1, "E").Value
.Cells(RowCrnt, "F").Value = .Cells(RowCrnt - 1, "F").Value
.Cells(RowCrnt, "G").Value = .Cells(RowCrnt - 1, "G").Value
.Cells(RowCrnt, "I").Value = .Cells(RowCrnt - 1, "I").Value
.Cells(RowCrnt, "J").Value = .Cells(RowCrnt - 1, "J").Value
.Cells(RowCrnt, "K").Value = .Cells(RowCrnt - 1, "K").Value
.Cells(RowCrnt, "L").Value = .Cells(RowCrnt - 1, "L").Value
.Cells(RowCrnt, "M").Value = .Cells(RowCrnt - 1, "M").Value
.Cells(RowCrnt, "N").Value = .Cells(RowCrnt - 1, "N").Value
.Cells(RowCrnt, "O").Value = .Cells(RowCrnt - 1, "O").Value
Next
End If
RowCrnt = RowCrnt + 1
Loop
End With
End Sub
Here's one way to do it:
Sub splitcells()
Const SPLIT_PARAS As Long = 2 'split to this number of paragraphs in a cell
Dim ws As Worksheet, lr As Long, rw As Range, p As Long
Dim n As Long, arr, i, s As String, ub As Long, c As Range, sep As String
Set ws = ThisWorkbook.Worksheets(1)
lr = ws.Cells(Rows.Count, "H").End(xlUp).Row
'start at the bottom and loop up
Set rw = ws.Rows(lr).Range("A1:O1") 'range is *relative* to row...
Do While rw.Row >= 10 'loop over rows
Set c = rw.Columns("H")
If Len(c.Value) > 0 Then
arr = Split(c.Value, vbLf) 'split to array on newLine
ub = UBound(arr)
If ub > SPLIT_PARAS - 1 Then 'more paras than limit?
n = Application.Ceiling((ub + 1) / SPLIT_PARAS, 1) 'total rows required
rw.Offset(1).Resize(n - 1).EntireRow.Insert 'add rows below
rw.Offset(1).Resize(n - 1).Value = rw.Value 'copy row data to added rows
s = ""
p = 0
For i = 0 To ub 'loop over paragraphs and populate ColH on each line
p = p + 1
s = s & IIf(p > 1, vbLf, "") & arr(i)
If p = SPLIT_PARAS Then 'write accumulated string?
c.Value = s
Set c = c.Offset(1) 'next row down
s = "" 'clear string
p = 0 'reset count
End If
Next i
If p > 0 Then c.Value = s 'remainder?
End If 'needs to be split into additional rows
End If 'have value in H
Set rw = rw.Offset(-1) 'next row up
Loop
End Sub