-
Split text between cells Help Needed
hello new to the forum and the vb scene. Im using the code that was pasted in the post "id481". My problem is that what i would like is for the string of text to continue in the cell beneath the original cell but after it has insert a new row first underneath the original cell. thus pasting the remaining text into the new row. In effect pushing the rest of the spreadsheet down a row. can anyone help ?? original code is posted below :
[vba]
'********************************************
'In the worksheet module
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Len(Target) / Target.Width > Ratio Then SplitText
End Sub
'********************************************
'********************************************
'In the standard module
Option Explicit
'Default ratio for splitting; adjust to suit font size
Public Const Ratio = 0.23 'Suits Arial 10
Sub SplitText()
Dim MyText As String
Dim WrapLength As Long, StrLen As Long, j As Long
Dim SplitRatio As Double
Dim NextCell As Range
'SplitRatio = 0.22 'Set own value in place of InputBox if desired
SplitRatio = InputBox("Enter ratio", "Cell width/Characters", Ratio)
Application.EnableEvents = False
'Return to previous cell
If Application.MoveAfterReturnDirection = xlToRight Then
Set NextCell = ActiveCell
ActiveCell.Offset(0, -1).Select
Else
ActiveCell.Offset(-1).Select
End If
WrapLength = Int(ActiveCell.Width) * SplitRatio
'Analyse text for space preceding cell width and split text
Do
MyText = ActiveCell.Text
StrLen = Len(MyText)
If StrLen > WrapLength Then
For j = WrapLength To 0 Step -1
If j = 0 Then Exit For
If Mid(MyText, j, 1) = " " Then
ActiveCell.Formula = Left(MyText, j)
ActiveCell.Offset(1, 0).Formula = Right(MyText, StrLen - j)
Exit For
End If
Next
ActiveCell.Offset(1, 0).Select
End If
Loop Until Len(ActiveCell) <= WrapLength
ActiveCell.Offset(1, 0).Select
'Move to right based on MoveAfterEnter
If Not NextCell Is Nothing Then NextCell.Select
Application.EnableEvents = True
End Sub
Sub Retry()
Dim Cel
Dim MyText As String
Application.EnableEvents = False
'Cocatenate cell strings
For Each Cel In Selection
MyText = MyText & Cel
Cel.ClearContents
Next
'Move to first cell of selection and write text
Selection.Cells(1).Select
Selection.Formula = MyText
'Move to next cell
If Application.MoveAfterReturnDirection = xlToRight Then
ActiveCell.Offset(0, 1).Select
Else
ActiveCell.Offset(1).Select
End If
SplitText
End Sub
'********************************************[/vba]
[uvba].[/uvba]
~Oorang
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules