Option Explicit
Sub DisplayLongText()
Dim cel As Range
Dim col As Long
For Each cel In Selection
AddLineFeeds cel, col
Next
col = 0
End Sub
Sub AddLineFeeds(cel As Range, col As Long)
Static lineIncr As Long
Dim i As Long, j As Long, pos As Long, StartPos As Long
Dim sLeft As String, str As String, sRight As String, sLineFeed As String
StartPos = 1
With cel
If Len(.Value) <= StartPos Then Exit Sub
sLineFeed = Chr(160) & Chr(10)
str = Replace(.Value, sLineFeed, " ")
If .Column <> col Then
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
If StartPos < lineIncr Then StartPos = lineIncr
End If
sLeft = Left(str, StartPos)
pos = InStrRev(sLeft, " ")
If pos = 0 Then
sLeft = sLeft & sLineFeed
sRight = Mid(str, StartPos + 1)
Else
sLeft = Left(str, pos - 1) & sLineFeed
sRight = Mid(str, pos + 1)
End If
pos = 1
Do
j = InStr(pos, sRight, Chr(10))
If j > 0 And j - pos <= lineIncr Then
pos = j + 1
Else
i = InStrRev(sRight, " ", pos + lineIncr)
If i > pos Then
sRight = Left(sRight, i - 1) & sLineFeed & Mid(sRight, i + 1)
pos = i + 2
Else
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
Loop
.Value = sLeft & sRight
End With
End Sub
|