How do I get out of this infinite loop?

[Goodluckboss]

Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 0

  MaxChars = 35
  On Error GoTo NoCellsSelected
  Set Source = Range("A:A")
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
        CellWithText.Offset(, DestinationOffset).Resize(, UBound(Lines) + 1) = Lines
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub

This code splits up cells that have more than 35 chars but even when I have only 4 rows of filled cells, it never exits the loop

 

[Fluff]

You are running that code on 1,048,576 cells, try using

Set Source = Range("A1", Range("A"&rows.count).end(xlup))

 

[Goodluckboss]

Let me try that now

 

[Goodluckboss]

Hi there tried it but it still won't get out of the loop. Is there anyway I can upload the excel here?

 

[Goodluckboss]

'Split Whole Words 35 Chars to 2 Columns in Column C to E
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 0

  MaxChars = 35
  On Error GoTo NoCellsSelected
  Set Source = Range("C2:E999")

  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
        CellWithText.Offset(, DestinationOffset).Resize(, UBound(Lines) + 1) = Lines
    End If
  Next
  Exit Sub
 
NoCellsSelected:

This was my amended code as I have to split 2 different columns of words

 

[Fluff]

You cannot upload files to the site, but you can use the XL2BB add-in to post some sample data. XL2BB

 

[Goodluckboss]

Solved it Thank you

 

[Fluff]

Glad to hear & thanks for the feedback