Parsing a string

[harm.charles]

Hi, I need some help on this.

I have sentence i column "A" row 1. This can be a variable length.
In column "H" I have the column set to receive for now 20 characters.
I'm trying to take the entire sentence and parse it to rows in column
"H"
Each row would have whole words.

This is the start of the code I'm working with.

Sub Mytest()


LENGTHOFCELL = Len(ActiveCell)
cnt = 20 '' nr of characters
cnt1 = 1''set first character
rcnt = 1''row nr
Do While cnt < LENGTHOFCELL
mystring = Mid(ActiveCell.Value, cnt1, 20)
Cells(rcnt, 8).Value = firstname
cnt1 = cnt + 1
cnt = cnt + 20
rcnt = rcnt + 1
mystring = ""
Loop

End Sub

This works some what. I know that this code will exit when the cnt
exceeds the LENGTHOFCELL.
Any help would be appreciated.

 

[Gary Keramidas]

here's something you can try:

Sub test()
Dim ws As Worksheet
Dim i As Long
Dim sWord As Variant
Set ws = Worksheets("Sheet1")
i = 1
sWord = Split(ws.Range("A1").Value, " ")
For i = 0 To UBound(sWord)
ws.Range("h" & i + 1).Value = sWord(i)
Next
End Sub

 

[RB Smissaert]

It all depends on what you define as a word.
If words are separated by spaces or linebreaks then you could do something
like this:
Replace all linebreaks with spaces.
Replace all double spaces (chr(32) & chr(32) ) with single spaces.
Then do a split (look up in the VBA help if you don't know the Split
function)
on the space character and you have all your words in an 0-based 1-D array,
so you can loop through that array and put the words in rows.
This will give you some idea how to approach this.

RBS

 

[harm.charles]

It all depends on what you define as a word.
If words are separated by spaces or linebreaks then you could do something
like this:
Replace all linebreaks with spaces.
Replace all double spaces (chr(32) & chr(32) ) with single spaces.
Then do a split (look up in the VBA help if you don't know the Split
function)
on the space character and you have all your words in an 0-based 1-D array,
so you can loop through that array and put the words in rows.
This will give you some idea how to approach this.

RBS

Thanks for the reply and you code works. How ever what I'm looking for
is something like this:
The sentence is : This is a test not that I really want it to be a
test.
The sentence will be variable and I have column "H" set to currently
for testing to 20 characters.
As for splitting the word if my variable happens to be set so that it
see "really" as "real" the I want "really" to go to the next row and
the next row can only hold 20 characters.ect..

In column "H"

This is a test
not that I really
want it to be
a test

 

[Gary Keramidas]

threw this together real quick because i have to leave, so i'm not sure it
will work for you or not. maybe you'll get an idea from it.

Sub Mytest()

Dim LENGTHOFCELL As Long
Dim cnt As Long
Dim cnt1 As Long
Dim z As Long
Dim x As Long
Dim rcnt As Long
Dim mystring As String

x = 1
Columns("H").ClearContents
LENGTHOFCELL = Len(Range("A1"))
cnt = 20 '' nr of characters
cnt1 = 1 ''set first character
rcnt = 1 ''row nr
mystring = Mid(Range("A1"), 1, 20)
Do While cnt < LENGTHOFCELL
'
If Right(mystring, 1) = " " Then
Range("H" & rcnt).Value = mystring
x = x + 20
Else
z = InStrRev(mystring, " ", Len(mystring))
Range("H" & rcnt).Value = Mid(mystring, x, z)
x = z
End If
cnt = cnt + z
rcnt = rcnt + 1
mystring = Mid(Range("A1"), x, 20)

Loop
Range("H" & rcnt).Value = mystring
End Sub



--

Gary
Excel 2003

It all depends on what you define as a word.
If words are separated by spaces or linebreaks then you could do something
like this:
Replace all linebreaks with spaces.
Replace all double spaces (chr(32) & chr(32) ) with single spaces.
Then do a split (look up in the VBA help if you don't know the Split
function)
on the space character and you have all your words in an 0-based 1-D
array,
so you can loop through that array and put the words in rows.
This will give you some idea how to approach this.

RBS

Thanks for the reply and you code works. How ever what I'm looking for
is something like this:
The sentence is : This is a test not that I really want it to be a
test.
The sentence will be variable and I have column "H" set to currently
for testing to 20 characters.
As for splitting the word if my variable happens to be set so that it
see "really" as "real" the I want "really" to go to the next row and
the next row can only hold 20 characters.ect..

In column "H"

This is a test
not that I really
want it to be
a test

 

[Rick Rothstein]

This macro should do what you asked for...

Sub SplitText20()
Dim R As Range
Dim X As Long
Dim Text As String
Dim Twenty As String
Set R = Range("H1")
Text = WorksheetFunction.Trim(Range("A1").Value)
Do While Len(Text) > 0
Twenty = Left(Text, 20)
If Mid(Text, 21, 1) = " " Then
R.Value = Trim(Twenty)
Text = Trim(Mid(Text, 21))
ElseIf Len(Twenty) < 20 Then
R.Value = Trim(Twenty)
Exit Do
Else
R.Value = Trim(Left(Twenty, InStrRev(Twenty, " ")))
Text = Trim(Mid(Text, InStrRev(Twenty, " ")))
End If
Set R = R.Offset(1)
Loop
End Sub

--
Rick (MVP - Excel)

It all depends on what you define as a word.
If words are separated by spaces or linebreaks then you could do something
like this:
Replace all linebreaks with spaces.
Replace all double spaces (chr(32) & chr(32) ) with single spaces.
Then do a split (look up in the VBA help if you don't know the Split
function)
on the space character and you have all your words in an 0-based 1-D
array,
so you can loop through that array and put the words in rows.
This will give you some idea how to approach this.

RBS

Thanks for the reply and you code works. How ever what I'm looking for
is something like this:
The sentence is : This is a test not that I really want it to be a
test.
The sentence will be variable and I have column "H" set to currently
for testing to 20 characters.
As for splitting the word if my variable happens to be set so that it
see "really" as "real" the I want "really" to go to the next row and
the next row can only hold 20 characters.ect..

In column "H"

This is a test
not that I really
want it to be
a test

 

[Rick Rothstein]

The following nonsense sentence demonstrates a problem with your code...

This istadn an test notest that I really and want it to be as test.

 

[harm.charles]

The following nonsense sentence demonstrates a problem with your code...

This istadn an test notest that I really and want it to be as test.

Thanks for the reply.
I went with Ricks code.
Gary your code came close and I learned from it as I do with all the
help I receive and read on this forum.

 

[Ron Rosenfeld]

This macro should do what you asked for...

Sub SplitText20()
Dim R As Range
Dim X As Long
Dim Text As String
Dim Twenty As String
Set R = Range("H1")
Text = WorksheetFunction.Trim(Range("A1").Value)
Do While Len(Text) > 0
Twenty = Left(Text, 20)
If Mid(Text, 21, 1) = " " Then
R.Value = Trim(Twenty)
Text = Trim(Mid(Text, 21))
ElseIf Len(Twenty) < 20 Then
R.Value = Trim(Twenty)
Exit Do
Else
R.Value = Trim(Left(Twenty, InStrRev(Twenty, " ")))
Text = Trim(Mid(Text, InStrRev(Twenty, " ")))
End If
Set R = R.Offset(1)
Loop
End Sub

There is a problem if the sentence has any lines with no spaces. That could
happen depending on the placement of a <LF>, or if there happened to be a word
longer than the requisite 20 characters.

Here is a regex solution. I chose to merely accept words longer than 20
characters, but I suppose one could include hyphenation rules if the OP wants
that.

=========================================
Option Explicit
Sub WordWrapV()
'Wraps at W characters, but will allow overflow if a line is longer than W
Dim re As Object, mc As Object, m As Object
Dim Str As String
Dim W As Long
Dim mBox
Dim rSrc As Range, rDest As Range
Dim i As Long
Const lDestOffset As Long = 0

Set rSrc = Range("A1")
Set rDest = Range("H1")
Set re = CreateObject("vbscript.regexp")
re.Global = True
W = 20

Str = rSrc.Value
'remove all line feeds and nbsp
'replace with <space>
re.Pattern = "[\xA0\r\n]"
Str = re.Replace(Str, " ")
re.Pattern = "\s?((\S[\s\S]{1," & W - 2 & _
"}\S)|(\S[\s\S]{" & W - 1 & ",}?\S))(\s|$)"
If re.Test(Str) = True Then
Set mc = re.Execute(Str)

'Blank destination cells
i = lDestOffset + 1
Do Until i > mc.Count + lDestOffset
If Len(rDest(i, 1)) <> 0 Then
mBox = MsgBox("Data in " & rDest(i, 1).Address _
& " will be erased if you contine", vbOKCancel)
If mBox = vbCancel Then Exit Sub
End If
i = i + 1
Loop

i = lDestOffset + 1
For Each m In mc
rDest(i, 1).Value = m.SubMatches(0)
i = i + 1
Next m
End If
Set re = Nothing
End Sub
========================
--ron

 

[Rick Rothstein]

As Ron pointed out, I had forgotten about replacing the Line Feed with a
blank... I didn't even think about words longer than 20 characters. Here is
my code modified to account for both of these (I chose to do what Ron did
and just allow 20 character or longer words to be presented as is)...

Sub SplitText20()
Dim R As Range
Dim x As Long
Dim Text As String
Dim Twenty As String
Set R = Range("H1")
Text = WorksheetFunction.Trim(Replace(Range("A1").Value, vbLf, " "))
Do While Len(Text) > 0
Twenty = Left(Text, 20)
If InStr(Twenty, " ") = 0 Then
R.Value = Trim(Left(Text, InStr(Text, " ")))
Text = Trim(Mid(Text, InStr(Text, " ")))
ElseIf Mid(Text, 21, 1) = " " Then
R.Value = Trim(Twenty)
Text = Trim(Mid(Text, 21))
ElseIf Len(Twenty) < 20 Then
R.Value = Trim(Twenty)
Exit Do
Else
R.Value = Trim(Left(Twenty, InStrRev(Twenty, " ")))
Text = Trim(Mid(Text, InStrRev(Twenty, " ")))
End If
Set R = R.Offset(1)
Loop
End Sub

 

[RB Smissaert]

Here another approach:

Function SplitWords(strText As String, Optional lMaxLen As Long) As String()

Dim i As Long
Dim n As Long
Dim arrWords
Dim arrWordsFinal() As String

strText = Replace(strText, Chr(9), Chr(32), , , vbBinaryCompare)
strText = Replace(strText, Chr(10), Chr(32), , , vbBinaryCompare)
strText = Replace(strText, Chr(13), Chr(32), , , vbBinaryCompare)

Do While InStr(1, strText, " ", vbBinaryCompare) > 0
strText = Replace(strText, " ", " ", , , vbBinaryCompare)
Loop

arrWords = Split(strText, Chr(32))
ReDim arrWordsFinal(0 To UBound(arrWords))

For i = 0 To UBound(arrWords)
If Len(arrWordsFinal(n)) + Len(arrWords(i)) + 1 > lMaxLen Then
'start in new array element
n = n + 1
End If
If Len(arrWordsFinal(n)) = 0 Then
arrWordsFinal(n) = arrWords(i)
Else
arrWordsFinal(n) = arrWordsFinal(n) & " " & arrWords(i)
End If
Next i

'could do a Redim Preserve here on the final array, but no need
SplitWords = arrWordsFinal

End Function


Sub test()

Dim i As Long
Dim arr

arr = SplitWords(Cells(1), 20)

On Error Resume Next 'for example for if first word is a =
For i = 0 To UBound(arr)
If Len(arr(i)) > 0 Then
Cells(i + 1, 3) = arr(i)
Else
Exit For
End If
Next i

End Sub


RBS