Sub DisplayLongText()
'Adds line feed characters as required on cells in selection that are longer than 1024 characters
Dim cel As Range
Dim col As Long
For Each cel In Selection
AddLineFeeds cel, col
Next
col = 0 'Force line length dialog to display the next time sub runs
End Sub
Sub AddLineFeeds(cel As Range, col As Long)
'Adds line feed characters at end of each line of text. Some experimentation may be required to set number
'of characters at the wrapping point.
'Code requires Excel 2000 or later because of Replace and InStrRev functions
Static lineIncr As Long
Dim i As Long, j As Long, pos As Long
Dim sLeft As String, str As String, sRight As String, sLineFeed As String
With cel
If Len(.Value) <= 1024 Then Exit Sub
'Remove line feed characters which may have been added previously. These always follow an ASCII 160 space.
sLineFeed = Chr(160) & Chr(10) 'Code puts an ASCII 160 space before every added line feed character
str = Replace(.Value, sLineFeed, " ")
'The maximum permitted number of characters on a line. User-specified up to a limit of 256 characters/line
If .Column <> col Then 'Use same value as last time if still working in same column
lineIncr = Application.Min(InputBox(Prompt:="Please specify the desired column width (in characters)", _
Title:="Long Text In Cell Utility", Default:=.ColumnWidth - 1), 256)
col = .Column
End If
sLeft = Left(str, 1022) 'Excel has no problem wrapping the first 1024 characters
pos = InStrRev(sLeft, " ") 'Find right-most space in first 1022 characters
If pos = 0 Then 'No space found, so force a break after 1022 characters
sLeft = sLeft & sLineFeed
sRight = Mid(str, 1023)
Else 'Put ASCII 160 plus line feed characters in place of this right-most space
sLeft = Left(str, pos - 1) & sLineFeed
sRight = Mid(str, pos + 1)
End If
pos = 1 'Loop through remainder of text, looking for places to put ASCII 160 plus line feed characters
Do
j = InStr(pos, sRight, Chr(10))
If j > 0 And j - pos <= lineIncr Then
pos = j + 1
Else
i = InStrRev(sRight, " ", pos + lineIncr) 'Find right-most space in next lineIncr characters
If i > pos Then 'Put ASCII 160 plus line feed characters in place of this right-most space
sRight = Left(sRight, i - 1) & sLineFeed & Mid(sRight, i + 1)
pos = i + 2
Else 'Didn't find a good place to break the line, so force the break in middle of a word
sRight = Left(sRight, pos + lineIncr) & sLineFeed & Mid(sRight, pos + lineIncr + 1)
pos = pos + lineIncr + 3
End If
End If
If Len(sRight) - pos < lineIncr Then Exit Do 'Not enough text left for a full line
Loop
.Value = sLeft & sRight 'Put the rebuilt string in place of the original
End With
End Sub