View Full Version : Split a cell into multiple cells
Rakesh
04-01-2012, 03:08 PM
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
04-01-2012, 03:54 PM
When there is wrap text, what determines where the split happens?
Aussiebear
04-01-2012, 04:07 PM
Would it be the current width of the column Bob?
Bob Phillips
04-01-2012, 04:19 PM
I wouldn't want to write that code Ted.
mikerickson
04-01-2012, 09:58 PM
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
04-02-2012, 12:33 AM
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
04-02-2012, 09:13 AM
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
04-02-2012, 11:59 AM
There are two copies of the function LinesOfText in that posting. Remove one of them.
jack kallis
04-03-2012, 05:28 AM
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
04-03-2012, 05:22 PM
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
04-03-2012, 08:05 PM
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
07-09-2012, 12:24 PM
Hey jack,, it is workin. great job. keep it up......
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.