Break Text at First Space Before Char 75, Insert Line and Move Char 75+ to New Line

[sherryjoo]

I have about 16K lines of text that need to be broken into new lines at the speace before character number 75, then moved to the next inserted line, and done recusivly until all of the text is in blocks like wrapped text. I copied the code below from the internet too long ago to remember to whom to give credit, but I cannot get it to work on my extract. Any help would be greatly appreciated!!!

Extract Value; Training at remote customer facility, includes trainer T&L expenses. Cost is for up to 6 students. Basic use and care of XLPRO or PRO PLUS. Menu System, Storing still images, Storing video data (XLPRO Plus only), Annotation, Basic Measurement techniques of Stereo, Shadow and comparison measurements. Contact factory for availability."

Sub splittext()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, Chr(75))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals

[mdmackillop]

I would not try to do this recursively for so many rows. This will process each cell and insert the split data on Sheet2


Option Explicit
Sub SplitText()
'splits Text active cell max length 75 characters
Dim arr(), j As Long, k As Long
Dim x As Long
Dim sh As Worksheet
Dim ws As Worksheet
Dim i As Long, r As Long
Dim txt As String


Set ws = Sheets(1) 'Source
Set sh = Sheets(2) 'Target

ReDim arr(100)
x = 75
r = ws.Cells(Rows.Count, 1).End(xlUp).Row

For k = 1 To r
j = 0
arr(0) = 1
Do
txt = ws.Cells(k, 1)
j = j + 1
arr(j) = InStrRev(txt, " ", x)
x = arr(j) + 75

Loop Until arr(j) = 0
arr(j) = Len(txt)
ReDim Preserve arr(j)
For i = 0 To j - 1
sh.Cells(Rows.Count, 1).End(xlUp)(2) = Mid(txt, arr(i), arr(i + 1) - arr(i))
Next
ReDim arr(100)
Next k
End Sub

[sherryjoo]

Thank you so much for your response, but I get an "Invalid procedure call or argument" error on this line. Again - thanks for your help!
sh.Cells(Rows.Count, 1).End(xlUp)(2) = Mid(txt, arr(i), arr(i + 1) - arr(i))

[mdmackillop]

Can you post a workbook with sample text.

[sherryjoo]

I've attached a sample workbook. I need to have the text in column B break at the space before the 75th character and go to a new line. If at all possible, I would like to keep the data in column A with the new lines in column B. Perhaps just repeating? THANK YOU SO MUCH!

[mdmackillop]

If the funcionality is correct, then cut and paste the result where you need it and delete the unwanted sheet.
Option Explicit
Sub SplitText()
'splits Text active cell max length 75 characters
Dim arr(), j As Long, k As Long
Dim x As Long
Dim sh As Worksheet
Dim ws As Worksheet
Dim i As Long, r As Long
Dim txt As String
Dim col As Long
Dim PN As String
Dim a As Long

Application.ScreenUpdating = False

'Text column
col = 2

Set ws = Sheets(1) 'Source
Set sh = Sheets.Add 'Target


ReDim arr(1000)
x = 75
r = ws.Cells(Rows.Count, 1).End(xlUp).Row

For k = 1 To r
j = 0
a = 0
arr(0) = 1
If Len(ws.Cells(k, col)) > 75 Then
PN = ws.Cells(k, col - 1)
Do
txt = ws.Cells(k, col)
j = j + 1
arr(j) = InStrRev(txt, " ", x)
x = arr(j) + 75
Loop Until arr(j) = 0
'Add last of text
arr(j) = Len(txt)
ReDim Preserve arr(j)
'Get Product Number
sh.Cells(Rows.Count, col).End(xlUp)(2).Offset(, -1) = PN
'Write Values
For i = 0 To j - 1
If i = j - 1 Then a = 1 'adjustment for last character
sh.Cells(Rows.Count, col).End(xlUp)(2) = Mid(txt, arr(i), arr(i + 1) - arr(i) + a)
Next
Else
'Short text
sh.Cells(Rows.Count, col).End(xlUp)(2).Offset(, -1) = ws.Cells(k, col - 1)
sh.Cells(Rows.Count, col).End(xlUp)(2) = ws.Cells(k, col)
End If
'Clear array
ReDim arr(1000)
Next k
sh.Columns("A:B").Columns.AutoFit
Application.ScreenUpdating = True
End Sub

[sherryjoo]

You are amazing!!! Thank you so much!

[snb]

or ?

Sub M_snb()
sn = Sheet1.Columns(2).SpecialCells(2)

For j = 1 To UBound(sn)
For jj = 1 To Len(sn(j, 1)) \ 75
sn(j, 1) = Left(sn(j, 1), jj * 75 + jj - 1) & vbLf & Mid(sn(j, 1), jj * 75 + jj)
Next
Next

Sheet1.Columns(2).SpecialCells(2) = sn
End Sub

[mdmackillop]

Nice solution but...

at the space before character number 75

[snb]

In that case:


Sub M_snb()
sn = Sheet1.Columns(2).SpecialCells(2)

For j = 1 To UBound(sn)
For jj = 1 To Len(sn(j, 1)) \ 75
sp = Split(Left(sn(j, 1), jj * 75))
If sp(UBound(sp)) <> "" Then
sp(UBound(sp)) = vbLf & sp(UBound(sp))
Else
sp(UBound(sp)) = vbLf
End If
sn(j, 1) = Replace(Join(sp), " " & vbLf, vbLf) & Mid(sn(j, 1), jj * 75 + 1)
Next
Next

Sheet1.Columns(2).SpecialCells(2) = sn
End Sub

[snb]

I made some improvements in order to get the exact result you are asking for. The results will be written into column D so you will be able to compare in detail the results with the original data.


Sub M_snb()
sn = Sheet1.Columns(2).SpecialCells(2)

For j = 1 To UBound(sn)
sp = Split(sn(j, 1), vbLf)
Do Until Len(sp(UBound(sp))) < 76
sq = Split(Left(sp(UBound(sp)), 75))
If sq(UBound(sq)) <> "" Then
sq(UBound(sq)) = vbLf & sq(UBound(sq))
Else
sq(UBound(sq)) = vbLf
End If
sp(UBound(sp)) = Replace(Join(sq), " " & vbLf, vbLf) & Mid(sp(UBound(sp)), 76)
sn(j, 1) = Join(sp, vbLf)
sp = Split(sn(j, 1), vbLf)
Loop
Next

Sheet1.Columns(2).SpecialCells(2).Offset(, 2) = sn
End Sub