split sentence into columns automatically

  • Thread starter Thread starter PeterCheang
  • Start date Start date
P

PeterCheang

My column A having a sentence like this (e.g The analog
input card requires the PLC logic to configure it for
proper operation.)and wanted to distribute them into
columns.
For each column only allow contain 20 characters.If total
words and space are excess 20 character,then the last word
must move to next column.So that the outcome looks like :
column B = The ananlog input
column C = card requires the
column D = PLC logic to
column E = configure it for
column F = proper operation.
 
Which route do you want to go? The most obvious non-VBA solution would be to
allow column A to remain as-is, and set up formulas in the cells to the
right of column A which would pull the appropriate characters from the text
in the cell in comumn A which is on the same row. Perhaps you would have
about 10 cells to the right of "A" , which would each have a formula that
would pull the correct characters fro mthe sentence.

Then you have the VBA option where you write a macro to do all of the work.

What is your choice?

Richard Choate

My column A having a sentence like this (e.g The analog
input card requires the PLC logic to configure it for
proper operation.)and wanted to distribute them into
columns.
For each column only allow contain 20 characters.If total
words and space are excess 20 character,then the last word
must move to next column.So that the outcome looks like :
column B = The ananlog input
column C = card requires the
column D = PLC logic to
column E = configure it for
column F = proper operation.
 
Here's some code that may help. It assumes you have selected a single cell or a vertical range
of multiple rows x 1 column. If you have selected multiple columns, only the 1st column is
processed. The assumption is that the proper number of columns to the right are blank. Any data
there will be overwritten without warning.

Option Explicit

Sub SplitText()
Dim Cell As Range
Dim Length As Long
Dim s As Long
Dim sp As Long
Dim sSegment As String
Dim sText As String
Dim TheSegments() As String

Const MaxLength As Long = 20

For Each Cell In Selection.Columns(1).Cells
sText = Application.Trim(Cell.Text) 'remove runs of spaces
Length = Len(sText)
Erase TheSegments()
s = 0

Do While Length > 0
If Length > MaxLength Then
sp = InStrRev(sText, " ", MaxLength + 1)
If sp Then
sSegment = Left$(sText, sp - 1)
sText = Mid$(sText, sp + 1)
Else
sSegment = Left$(sText, MaxLength)
sText = Mid$(sText, MaxLength + 1)
End If
Length = Len(sText)

Else
sSegment = sText
Length = 0

End If

s = s + 1
ReDim Preserve TheSegments(1 To s)
TheSegments(s) = sSegment
Loop
Cell.Offset(0, 1).Resize(1, s).Value = TheSegments
Next Cell
End Sub
 
You could use data / Text To Columns / Fixed Width and just put the breaks in at every 20
characters, or if you preferred a formula, then perhaps the following.

With your data in Col A, starting in A1.

In B1 =MID($A2,((COLUMN()-1)*20)-1,20)

Then just copy as far down and across as necessary.

If you wanted to know how far you had to take the formulas across, and didn't want to just wait
till you got blanks, then you could use something like the following in a cell somewhere:-

="Col "&MID(ADDRESS(1,ROUNDUP(MAX(LEN(A2:A9))/20,0)-1),2,1) array entered CTRL+SHIFT+ENTER
 
Aww shoot - Forget that - Just reread the note and realised you wanted whole words in each of the
columns - My note just breaks it up into 20s.
 
Larson.
Excellent,it work perfect and suit for my need.
Thank You.
-----Original Message-----
Here's some code that may help. It assumes you have
Click to expand...
selected a single cell or a vertical range
of multiple rows x 1 column. If you have selected
Click to expand...
multiple columns, only the 1st column is
processed. The assumption is that the proper number of
Click to expand...
columns to the right are blank. Any data
there will be overwritten without warning.

Option Explicit

Sub SplitText()
Dim Cell As Range
Dim Length As Long
Dim s As Long
Dim sp As Long
Dim sSegment As String
Dim sText As String
Dim TheSegments() As String

Const MaxLength As Long = 20

For Each Cell In Selection.Columns(1).Cells
sText = Application.Trim(Cell.Text) 'remove runs of spaces
Length = Len(sText)
Erase TheSegments()
s = 0

Do While Length > 0
If Length > MaxLength Then
sp = InStrRev(sText, " ", MaxLength + 1)
If sp Then
sSegment = Left$(sText, sp - 1)
sText = Mid$(sText, sp + 1)
Else
sSegment = Left$(sText, MaxLength)
sText = Mid$(sText, MaxLength + 1)
End If
Length = Len(sText)

Else
sSegment = sText
Length = 0

End If

s = s + 1
ReDim Preserve TheSegments(1 To s)
TheSegments(s) = sSegment
Loop
Cell.Offset(0, 1).Resize(1, s).Value = TheSegments
Next Cell
End Sub
Click to expand...
 
Both method are having thier own beauty,as long it can
work as your need.Do you agree?
 
The code I posted yesterday was put together hurriedly and didn't handle some possible errors
such as (1) a source cell that is empty (you can't resize a range to 0 columns!) or (2) a source
cell that is so close to the right edge of the worksheet that there aren't enough columns
available to handle the text (you can't resize a range so that it extends past column IV,
either!).

It also wasn't optimized for speed, i.e. turning of screen updating, event processing, and
setting calculation to manual, minimizing the creation of new strings. The version below takes
care of those issues. It creates only one new string for each segment of the text (rather than
3).

Option Explicit
Option Base 0

Sub SplitText2()
Dim Cell As Range
Dim Length As Long
Dim MaxCols As Long
Dim p As Long
Dim s As Long
Dim sp As Long
Dim sText As String
Dim TheSegments() As String
Dim Settings As Variant

Const MaxLength As Long = 20
Const SpaceChar As String = " "

With Selection
MaxCols = .Parent.Columns.Count - .Column
End With
ReDim TheSegments(0 To MaxCols - 1)

With Application
Settings = Array(.Calculation, .ScreenUpdating, .EnableEvents)
End With

For Each Cell In Selection.Columns(1).Cells
sText = Application.Trim(Cell.Text)
Length = Len(sText)

If Length > 0 Then
s = 0
p = 1

Do While p <= Length
If s = MaxCols - 1 Then
'no more space to the right, so
'put entire tail into last column
TheSegments(s) = Mid$(sText, p)
p = Length + 1

ElseIf (Length - p + 1) > MaxLength Then
'more than MaxLength chars left, try to split it
sp = InStrRev(sText, SpaceChar, p + MaxLength)
If sp >= p Then
'space found, split text there
TheSegments(s) = Mid$(sText, p, sp - p)
p = sp + 1
Else
'no space found -- take MaxLength characters
'(i.e. will split in middle of a word)
TheSegments(s) = Mid$(sText, p, MaxLength)
p = p + MaxLength
End If

Else
'remaining text <= MaxLength characters,
'no need to split it
TheSegments(s) = Mid$(sText, p)
p = Length + 1
End If
s = s + 1
Loop
Cell.Offset(0, 1).Resize(1, s).Value = TheSegments()

End If

Next Cell

With Application
s = LBound(Settings)
.Calculation = Settings(s)
.ScreenUpdating = Settings(s + 1)
.EnableEvents = Settings(s + 2)
End With

End Sub
 
Back
Top