Split a cell into multiple cells

[Rakesh]

Hi Rocks,

I am using Excel Mac 2011.

I have a spreadsheet having multiple of column heads with cell format as wrap text, and some of the table heads with line break (Alt + Enter) in the cell.

Is there is a way to break the cell entries into multiple entries as look like visual view.
Is there is any coding for that.

Sorry I am unable to attach Excel File. My office IT Dept has restricted my access to upload excel file. So I have attached screen shot of my file for your reference.

Sorry for the inconvenience.

Thanks in Advance,
Rakesh

[Bob Phillips]

When there is wrap text, what determines where the split happens?

[Aussiebear]

Would it be the current width of the column Bob?

[Bob Phillips]

I wouldn't want to write that code Ted.

[mikerickson]

One could use something like this in connection with a Double Click event.
(This assumes that the font being used in the cells isn't very different than the Normal font.)

Sub TextToRows()
Dim oneCell As Range

For Each oneCell In Selection.Cells
AlterOneCell oneCell
Next oneCell
End Sub

Sub AlterOneCell(ByVal aRange As Range)
Dim cellText As String, newText As String
Dim newLines As Variant
Dim maxLetterCount As Long
Dim cellRow As Long, cellCol As Long

Set aRange = aRange.Cells(1, 1)
With aRange
maxLetterCount = Int(aRange.ColumnWidth * ThisWorkbook.Styles("Normal").Font.Size / aRange.Font.Size)
cellRow = .Row: cellCol = .Column

newText = FitString(.Text, maxLetterCount)
newLines = Split(newText, vbCr)

If 0 < UBound(newLines) Then

.Offset(1, 0).Resize(UBound(newLines), 1).Insert shift:=xlDown
Rem above inserts single cell, below inserts entire row
'.Offset(1, 0).Resize(UBound(newLines), 1).EntireRow.Insert shift:=xlDown

With .Parent.Cells(cellRow, cellCol).Resize(UBound(newLines) + 1, 1)
.Value = Application.Transpose(newLines)
aRange.AutoFill Destination:=.Cells, Type:=xlFillFormats
End With
End If

End With
End Sub

Function FitString(ByVal aString As String, maxLetters As Long) As String
Dim Words As Variant
Dim Paragraphs As Variant, pGraphIndex As Long
Dim Lines() As String
Dim Pointer As Long, i As Long

aString = Replace(aString, vbLf, vbCr)
Paragraphs = Split(aString, vbCr)

For pGraphIndex = 0 To UBound(Paragraphs)
Words = Split(Paragraphs(pGraphIndex), " ")
ReDim Lines(0 To UBound(Words) + 1)
Pointer = 0

For i = 0 To UBound(Words)
If Len(Lines(Pointer) & " " & Words(i)) <= maxLetters Then
Lines(Pointer) = Application.Trim(Lines(Pointer) & " " & Words(i))
Else
If Lines(Pointer) = vbNullString Then
Lines(Pointer) = Words(i)
Pointer = Pointer + 1
Else
Pointer = Pointer + 1
Lines(Pointer) = Words(i)
End If
End If
Next i

If Lines(Pointer) <> vbNullString Then Pointer = Pointer + 1
ReDim Preserve Lines(0 To Pointer - 1)
Paragraphs(pGraphIndex) = Join(Lines, vbCr)
Next pGraphIndex

FitString = Join(Paragraphs, vbCr)
End Function
One concern is: When inserting a cell to fill with the next line, should one insert a single cell (disarranging the rows) or insert an entire row.
The entire row option makes splitting cells on the same row problematic.

[mikerickson]

A slightly more refined version.

Select from the OP and run TextToRows

Sub TextToRows()
Dim wholeRange As Range
Dim i As Long
With Selection
Set wholeRange = .Cells
For i = .Rows.Count To 1 Step -1
Set wholeRange = Range(wholeRange, ExpansionOfOneRow(.Rows(i)))
Next i
With wholeRange
.WrapText = False
.Columns.AutoFit: Rem optional line, cheating?
End With
End With
End Sub

Function ExpansionOfOneRow(aRow As Range) As Range
Dim maxLetters As Long, baseSize As Single
Dim maxInsert As Long
Dim i As Long
Dim Lines() As Variant, oneLine As Variant

baseSize = ThisWorkbook.Styles("Normal").Font.Size
With aRow
ReDim Lines(1 To Columns.Count)

For i = 1 To .Columns.Count
With .Cells(1, i)
maxLetters = Int(.ColumnWidth * (baseSize / .Font.Size))

Lines(i) = LinesOfText(Application.Trim(.Text), maxLetters)

If maxInsert < UBound(Lines(i)) Then maxInsert = UBound(Lines(i))
End With
Next i

If 0 < maxInsert Then
Rem insert
.Offset(1, 0).Resize(maxInsert, .Columns.Column).Insert shift:=xlDown
Rem fill
With .Resize(maxInsert + 1, .Columns.Count)
For i = 1 To .Columns.Count
.Columns(i).Resize(UBound(Lines(i)) + 1, 1).Value = Application.Transpose(Lines(i))
Next i
aRow.AutoFill Destination:=.Cells, Type:=xlFillFormats

Set ExpansionOfOneRow = .Cells
End With

End If
End With
End Function

Function LinesOfText(ByVal aString As String, maxLetters As Long) As Variant
Dim Words As Variant
Dim Paragraphs As Variant, pGraphIndex As Long
Dim Lines() As String
Dim Pointer As Long, i As Long

aString = Trim(Replace(aString, vbLf, vbCr))
Paragraphs = Split(aString, vbCr)

For pGraphIndex = 0 To UBound(Paragraphs)
Words = Split(Paragraphs(pGraphIndex), " ")
ReDim Lines(0 To UBound(Words) + 1)
Pointer = 0

For i = 0 To UBound(Words)
If Len(Application.Trim(Lines(Pointer) & " " & Words(i))) <= maxLetters Then
Lines(Pointer) = Application.Trim(Lines(Pointer) & " " & Words(i))
Else
If Lines(Pointer) = vbNullString Then
Lines(Pointer) = Words(i)
Pointer = Pointer + 1
Else
Pointer = Pointer + 1
Lines(Pointer) = Words(i)
End If
End If
Next i

If Lines(Pointer) <> vbNullString Then Pointer = Pointer + 1
ReDim Preserve Lines(0 To Pointer - 1)
Paragraphs(pGraphIndex) = Join(Lines, vbCr)
Next pGraphIndex

LinesOfText = Split(Join(Paragraphs, vbCr), vbCr)
End Function


Sub AlterOneCell(ByVal aRange As Range)
Dim cellText As String, newText As String
Dim newLines As Variant
Dim maxLetterCount As Long
Dim cellRow As Long, cellCol As Long

Set aRange = aRange.Cells(1, 1)
With aRange
maxLetterCount = Int(aRange.ColumnWidth * ThisWorkbook.Styles("Normal").Font.Size / aRange.Font.Size)
cellRow = .Row: cellCol = .Column

newLines = LinesOfText(.Text, maxLetterCount)
If 0 < UBound(newLines) Then
.Offset(1, 0).Resize(UBound(newLines), 1).Insert shift:=xlDown
With .Parent.Cells(cellRow, cellCol).Resize(UBound(newLines) + 1, 1)
.Value = Application.Transpose(newLines)
aRange.AutoFill Destination:=.Cells, Type:=xlFillFormats
'.WrapText = False
' .Columns.AutoFit: Rem
End With
End If

End With
End Sub

Function LinesOfText(ByVal aString As String, maxLetters As Long) As Variant
Dim Words As Variant
Dim Paragraphs As Variant, pGraphIndex As Long
Dim Lines() As String
Dim Pointer As Long, i As Long

aString = Trim(Replace(aString, vbLf, vbCr))
Paragraphs = Split(aString, vbCr)

For pGraphIndex = 0 To UBound(Paragraphs)
Words = Split(Paragraphs(pGraphIndex), " ")
ReDim Lines(0 To UBound(Words) + 1)
Pointer = 0

For i = 0 To UBound(Words)
If Len(Application.Trim(Lines(Pointer) & " " & Words(i))) <= maxLetters Then
Lines(Pointer) = Application.Trim(Lines(Pointer) & " " & Words(i))
Else
If Lines(Pointer) = vbNullString Then
Lines(Pointer) = Words(i)
Pointer = Pointer + 1
Else
Pointer = Pointer + 1
Lines(Pointer) = Words(i)
End If
End If
Next i

If Lines(Pointer) <> vbNullString Then Pointer = Pointer + 1
ReDim Preserve Lines(0 To Pointer - 1)
Paragraphs(pGraphIndex) = Join(Lines, vbCr)
Next pGraphIndex

LinesOfText = Split(Join(Paragraphs, vbCr), vbCr)
End Function

[Rakesh]

Hi mikerickson,

I have tried the coding but it throws the following error.

Compile error

Ambiguous name detected: LinesOfText


Note: Wherever the line breaked in the View, there should be split happen.

Thanks,
Rakesh

[mikerickson]

There are two copies of the function LinesOfText in that posting. Remove one of them.

[jack kallis]

To divide a cell on to multiple cells:-
>>> Select the cell you want to divide into multiple cells.
>>> Right click the mouse and select "Split Cells" from the popup menu.
OR

>>> Click Table menu and select "Split Cells" from the drop down menu.
OR

>>> Click "Tables and Borders" button, "Tables and Borders" toolbar appears. Click "Split Cells" button.
>>> Enter number of columns and rows; you want to create in the selected cell.
>>> Click "OK" button of the "Split Cells" dialog box.

[Rakesh]

Hi mikerickson,

The coding is working. But the splitted cells line ending doesn't match as per the sample's line ending.
Is there a way to fix it?

Thanks,
Rakesh

[mikerickson]

I don't know a way to fix it. Slightly widening the cell before splitting should help keep the line breaking the same between the two versions.

[joecor]

Hey jack,, it is workin. great job. keep it up......