VBA to Add carriage return in cell after x number of character

[mbfg]

I looking for vb at will format cells in a column, at 27 characters it should insert a carriage return, however this return should not be in the middle of a word, if the break were to fall in the middle of a word it would go to the previous space.


So for example :

This is just a sample line of text to show how I would like it formatted

would change to the following :

This is just a sample line
of text to show how I would
like it formatted

Appreciate any help, I can get it to insert a return after x characters but only on the first occurance and cant work out to allow for not breaking words.

Steve.

[Rick Rothstein]

Give this macro a try (assumes your data is in Column A). Note the section I highlight in red as it controls where the output goes to.

Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String
  Dim Space As Long, MaxChars As Long
  Dim Source As Range, CellWithText As Range
  
  ' With offset as 1, split data will be adjacent to original data
  ' With offset = 0, split data will replace original data
  Const DestinationOffset As Long = 1

  MaxChars = 27
  On Error GoTo NoCellsSelected
  Set Source = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      If Right(TextMax, 1) = " " Then
        SplitText = SplitText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          SplitText = SplitText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          SplitText = SplitText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    CellWithText.Offset(, DestinationOffset).Value = SplitText & Text
  Next
  Exit Sub
NoCellsSelected:
End Sub

[jindon]

Try
Assuming the string is col.A.

Sub test()
    Dim r As Range, txt As String
    With CreateObject("VBScript.RegExp")
        .Global = True
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
            r = Application.Trim(Replace(r, vbLf, " "))
            .Pattern = "(.{1,27})( |$)"
            r = Application.Trim(Replace(r, vbLf, " "))
            r.Value = .Replace(r.Value, "$1" & vbLf)
            .Pattern = "\n+(?!.)"
            r.Value = .Replace(r.Value, "")
        Next
    End With
End Sub

If you are on Mac OS then

Sub testNonRegX()
    Dim r As Range, txt As String, n As Long, x(), temp As Long
    For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
        txt = Application.Trim(Replace(r, vbLf, " "))
        n = 0
        Do While Len(txt) > 27
            n = n + 1
            ReDim Preserve x(1 To n)
            temp = InStrRev(txt, " ", 28)
            x(n) = Trim$(Left$(txt, temp))
            txt = Trim$(Mid$(txt, temp + 1))
        Loop
        If Len(txt) Then
            n = n + 1: ReDim Preserve x(1 To n)
            x(n) = txt
        End If
        r.Value = Join(x, vbLf)
    Next
End Sub

[mbfg]

Excellent, thank you to both of you , both codes working perfectly!