Split data into next columns with 70 characters maximum

[Dazzawm]

I have data in column B like below. I want the data split into the next columns and each column must have a maximum of 70 characters. I don't want it cut off exactly at 70 as it may split a number within the cell. It will have to be at the last '/' before 70.

There may be some cells that won't have 70 so they can be ignored. Thanks

Excel 2010
	B
99	12-31-1-276-139/ 12-31-1-276-164/ 12-31-1-277-116/ 12-31-1-277-166/ 12-31-1-277-217/ 12-31-1-277-219/ 12-31-1-277-504/ 12-31-1-285-012/ 12-31-1-352-708/ 12-31-1-362-029/ 12-31-1-362-092/ 12-31-1-362-468/ 12-31-1-466-084/ 85-31-1-362-029/ 85-31-1-362-030
100	12-31-1-266-660/ 12-31-1-267-401/ 12-31-1-267-461/ 12-31-1-276-269/ 12-31-1-277-503/ 12-31-1-277-581/ 12-31-1-289-818/ 85-31-1-266-660/ 85-31-1-267-461/ 85-31-1-276-269
101	12-31-1-715-660/ 12-31-1-720-164/ 12-31-1-725-733/ 12-31-1-733-771/ 12311715659/ 12311733060/ 12311733772
Sheet1

 

[Rick Rothstein]

Did you have chance to look at this again Rick?

Sorry, I lost track of this thread... I am glad you decided to follow up. Here is a replacement for the WrapTextOnSpacesWithMaxCharactersPerLine macro which should fix the problem (I did not touch the Uniques function so leave that alone)...

[table="width: 500"]
[tr]
	[td]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
  
  Application.ScreenUpdating = False
  MaxChars = 70
  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Range("B2", Cells(Rows.Count, "B").End(xlUp))
  On Error GoTo 0
  For Each CellWithText In Source
    Text = Uniques(Replace(Replace(Replace(CellWithText.Value, "/ ", "//"), " ", Chr(1)), "//", "/ "), " ")
    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
    SplitText = Replace(SplitText & Text, Chr(1), " ")
    CellWithText.Offset(, DestinationOffset).Value = Replace(SplitText, "/" & vbLf, vbLf)
  Next
  Source.Offset(, DestinationOffset).TextToColumns Range("C2"), xlDelimited, , , False, False, False, False, True, vbLf
  Exit Sub
NoCellsSelected:
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[Dazzawm]

Thanks so much Rick, works perfect. Thanks for all your time.