'********************************************
 '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 
 '********************************************