wrap cells to another row

[De Tonya]

Row 1 contains cells that span colums A thru ZZ. The page break is at column
M. Is there a way to automatically wrap the text in cells N1 thru AA1 onto
A2 so that the data fits on one page?

 

[JMB]

I generally use this. The width of your column will determine where the text
breaks to the next line. So adjust column width prior to running, then
select the cells containing the text (multiple rows, single column) and run
the macro. Then reset your column width.

There's probably a cleaner way of doing it, but I wrote this a few years ago
when I was still learning VBA. It may put a leading space on some of your
sentences - I didn't know about TRIM back then.


Sub text_wrap()

Dim ColWidth As Single
Dim SelectionAddress As Variant
Dim Rw As Integer
Dim SplitTextString As Variant
Dim Count1 As Integer
Dim Count2 As Integer
Dim StartRange As Variant
Dim TextString As String

ColWidth = Selection.ColumnWidth
Rw = Selection.Rows.Count
StartRange = ActiveCell.Address
SelectionAddress = Selection.Address

For Each x In Range(SelectionAddress)
If x.Value = "" Then TextString = TextString & "_"
TextString = TextString & x.Value & " "
x.Value = ""
Next x

SplitTextString = Split(TextString, " ", -1, vbTextCompare)

Range(StartRange).Select
Selection.EntireColumn.Insert
Selection.ColumnWidth = ColWidth
Count1 = 0
Count2 = 1

Do While Count1 <= UBound(SplitTextString) - 1
Do While Selection.ColumnWidth <= ColWidth And Count1 <=
UBound(SplitTextString) - 1
Do While SplitTextString(Count1) = "_"
If Len(Selection.Value) > 0 Then
ActiveCell.Offset(0, 1).Value = Selection.Value
ActiveCell.Offset(1, 0).Select
Count2 = Count2 + 1
If Count2 > Rw Then Selection.EntireRow.Insert
End If
ActiveCell.Offset(1, 0).Select
Count2 = Count2 + 1
If Count2 > Rw And Count1 < UBound(SplitTextString) - 1 _
Then Selection.EntireRow.Insert
Count1 = Count1 + 1
Loop
If Count1 < UBound(SplitTextString) Then
Selection.Value = Selection.Value & SplitTextString(Count1) & " "
Selection.EntireColumn.AutoFit
Count1 = Count1 + 1
End If
Loop
If Count1 <= UBound(SplitTextString) And Len(Selection.Value) > 0 Then
Selection.Value = Left(Selection.Value, Len(Selection.Value) - 1)
Selection.EntireColumn.AutoFit
If Selection.ColumnWidth > ColWidth Then
Selection.Value = Left(Selection.Value, Len(Selection.Value) - _
Len(SplitTextString(Count1 - 1)) - 1)
Count1 = Count1 - 1
End If
Selection.ColumnWidth = ColWidth
ActiveCell.Offset(0, 1).Value = Selection.Value
ActiveCell.Offset(1, 0).Select
Count2 = Count2 + 1
If Count2 > Rw And Count1 < UBound(SplitTextString) _
Then Selection.EntireRow.Insert
End If
Loop

Selection.EntireColumn.Delete

End Sub

 

[JMB]

Oh yes, if you have a lot of text, I would run it on a few paragraphs at a
time. The text you select gets concatenated into a string variable - which
does have an upper limit on the number of characters it can contain (If I
remember correctly, it's a fairly large number - I've never run into that
problem).

Be sure to back up your work.