Count 30 Characters and insert new row with no word slice

[jaime1964]

Hello All;
I have a macro requirement were the macro reads a text in a cell; copies the first 30 characters; inserts the test into a new row. The macro contiues were it left off reading the next 30 characetrs and inserting a 2nd row pasting the text. This process continues until there is no more text to read in the cell.

Inaddition the macro should observe the following restrictions:
1) The macro should not slice into words...defauts to the beginning of the word were the 30 character mark is.
2) Inserts new rows instead of pasting. This is to prevent overwriting data below the cells were the souce cell is.

Sample output: Applying the macro to the first paragraph above it should look like this:

<TABLE style="WIDTH: 195pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=260><COLGROUP><COL style="WIDTH: 195pt; mso-width-source: userset; mso-width-alt: 9508" width=260><TBODY><TR style="HEIGHT: 165.75pt" height=221><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 195pt; HEIGHT: 165.75pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl63 height=221 width=260>I have a macro requirement
were the macro reads a text
in a cell; copies the first
50 characters; inserts
the test into a new row. The
macro contiues were it left
off reading the next 50
characetrs and inserting a
2nd row pasting the text.
This process continues until
there is no more text to read
in the
cell.</TD></TR></TBODY></TABLE>

Mr. Beaucaire solution to post "counting characters to 50 and adding to new line" July 5, 2009 does a great job however it slices into words and does not insert new rows.

Thank You All!
jaime

Mr. Beaucaire solution "counting characters to 50 and adding to new line"

Sub Split50()
Dim MyVal As String, i As Long
MyVal = Range("A1")

Do
i = i + 1
If Len(MyVal) > 50 Then
Range("A" & i) = Left(MyVal, 50)
MyVal = Right(MyVal, Len(MyVal) - 50)
Else
Range("A" & i) = MyVal
Exit Do
End If
Loop
End Sub

 

[shg]

One way:

Sub j()
    Dim iRow As Long
    Dim avs As Variant
 
    For iRow = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Len(Cells(iRow, "A").Value) Then
            avs = SubStrings(Cells(iRow, "A").Value, 30)
            Rows(iRow + 1).Resize(UBound(avs)).Insert
            Cells(iRow + 1, "A").Resize(UBound(avs)).Value = WorksheetFunction.Transpose(avs)
        End If
    Next iRow
End Sub
 
Function SubStrings(ByVal sInp As String, MaxLen As Long) As String()
    ' shg 2007
    Dim asOut() As String
    Dim iOut    As Long
    Dim iPos    As Long
 
    sInp = Replace(sInp, Chr(160), " ") ' change non-breaking spaces to spaces
    ReDim asOut(1 To Len(sInp) - Len(Replace(sInp, " ", "")))

 
    Do
        iOut = iOut + 1
        If Len(sInp) <= MaxLen Then
            asOut(iOut) = sInp
            Exit Do
        Else
            iPos = InStrRev(Left(sInp, MaxLen + 1), " ")
            If iPos = 0 Then
                asOut(iOut) = "Unable to split."
                Exit Do
            Else
                asOut(iOut) = Left(sInp, iPos - 1)
                sInp = Mid(sInp, iPos + 1)
            End If
        End If
    Loop While Len(sInp)
 
    ReDim Preserve asOut(1 To iOut)
    SubStrings = asOut
End Function

 

[jbeaucaire]

My update:

Sub Split30()
Dim MyVal As String, i As Long, MyArr As Variant, buf As String
MyArr = Split(Range("A1"), " ")

For i = LBound(MyArr) To UBound(MyArr)
    If Len(buf & " " & MyArr(i)) > 30 Then
        Range("A" & Rows.Count).End(xlUp).Offset(1).Value = WorksheetFunction.Trim(buf)
        buf = ""
    End If
    buf = buf & " " & MyArr(i)
    If i = UBound(MyArr) Then Range("A" & Rows.Count).End(xlUp).Offset(1).Value = WorksheetFunction.Trim(buf)
Next i

End Sub

 

[jbeaucaire]

this version will apply to the ACTIVECELL as source, and will shift cells below downward:

Sub Split30()
Dim MyVal As String, i As Long, MyArr As Variant, buf As String
MyArr = Split(ActiveCell, " ")

    For i = LBound(MyArr) To UBound(MyArr)
        If Len(buf & " " & MyArr(i)) > 30 Then
            ActiveCell.Offset(1).Select
            ActiveCell.EntireRow.Insert xlShiftDown
            ActiveCell.Value = WorksheetFunction.Trim(buf)
            buf = ""
        End If
        buf = buf & " " & MyArr(i)
    Next i
    ActiveCell.Offset(1).Select
    ActiveCell.EntireRow.Insert xlShiftDown
    ActiveCell.Value = WorksheetFunction.Trim(buf)

End Sub

 

[hiker95]

jaime1964,

See:

By Rick Rothstein
Wrap Text On Spaces Up To A Maximum Number Of Characters Per Line
Sub WrapTextOnSpacesWithMaxCharactersPerLine()
http://www.excelfox.com/forum/f22/wrap-text-spaces-up-maximum-number-characters-per-line-355/