Split data into next columns with 70 characters maximum

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,786
Office Version
  1. 365
Platform
  1. Windows
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
9912-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
10012-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
10112-31-1-715-660/ 12-31-1-720-164/ 12-31-1-725-733/ 12-31-1-733-771/ 12311715659/ 12311733060/ 12311733772
Sheet1
 
Sort by date Sort by votes
MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG18Jul49
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Ray, Sp [COLOR=Navy]As[/COLOR] Variant, K [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nLen [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nStr [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    
    Sp = Split(Dn.Value, "/ ")
    [COLOR=Navy]If[/COLOR] UBound(Sp) = 0 [COLOR=Navy]Then[/COLOR]
        Dn.Offset(, 1).Value = Dn
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]For[/COLOR] n = 0 To UBound(Sp)
          [COLOR=Navy]If[/COLOR] Not .Exists(Sp(n)) [COLOR=Navy]Then[/COLOR]
            .Add (Sp(n)), Nothing
          [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] n
        ReDim Ray(1 To .Count)
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] .keys
          nLen = nLen + Len(K)
                    [COLOR=Navy]If[/COLOR] nLen > 70 [COLOR=Navy]Then[/COLOR]
                        nLen = Len(K)
                         c = c + 1
                         Ray(c) = nStr
                        nStr = K
                    [COLOR=Navy]Else[/COLOR]
                        nStr = nStr & IIf(nStr = "", K, "/ " & K)
                    [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] K
    
            [COLOR=Navy]If[/COLOR] nStr > "" [COLOR=Navy]Then[/COLOR]
                c = c + 1
                Ray(c) = nStr
            [COLOR=Navy]End[/COLOR] If
            Dn.Offset(, 1).Resize(, c).Value = Ray
            Dn.Offset(, 1).Resize(, c).WrapText = True
            c = 0: nStr = "": nLen = 0
    [COLOR=Navy]End[/COLOR] If
  [COLOR=Navy]End[/COLOR] With
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...

Hi Mick, not sure whats happened but this code isn't splitting by <70. Some cells say 74, 75 etc by using LEN function. Not sure if it ever worked and I never noticed?
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Dazzawm said:
Hi Mick, not sure whats happened but this code isn't splitting by <70. Some cells say 74, 75 etc by using LEN function. Not sure if it ever worked and I never noticed?
Click to expand...
Does this code work for you (you execute the WrapTextOnSpacesWithMaxCharactersPerLine macro, it will call the Uniques function as it needs to)...
Code: 
[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

  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(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
  Columns("C").TextToColumns , xlDelimited, , , False, False, False, False, True, vbLf
  Exit Sub
NoCellsSelected:
End Sub

Function Uniques(Text As String, Delimiter As String) As String
  Dim X As Long, Data() As String
  Data = Split(Text, Delimiter)
  With CreateObject("Scripting.Dictionary")
    For X = 0 To UBound(Data)
      .Item(Data(X)) = 1
    Next
    Uniques = Join(.keys, Delimiter)
  End With
End Function[/td]
[/tr]
[/table]
 
Upvote 0
Hi Rick, just went to use this but I noticed some but not all that when it gets split it has a trailing '/' like below. Any way this could be removed please? Like after the 8061 in B.

Excel 2010
BC
12-31-7-515-030-02/ 7515030/ 7515030-02/ 12317515030/ 8061/0986080610/ AL9434X/ YLE102340/ YLE102340

<colgroup><col style="width: 25pxpx" https:="" www.mrexcel.com="" forum="" usertag.php?do="list&action=hash&hash=DAE7F5"" target="_blank"></colgroup><colgroup><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]26[/TD]

</tbody>
Sheet3​
 
Last edited:
Upvote 0
I am also coming across quite a few with more than 70 characters?
 
Upvote 0
Dazzawm said:
Hi Rick, just went to use this but I noticed some but not all that when it gets split it has a trailing '/' like below. Any way this could be removed please? Like after the 8061 in B.

Excel 2010
BC
12-31-7-515-030-02/ 7515030/ 7515030-02/ 12317515030/ 8061/0986080610/ AL9434X/ YLE102340/ YLE102340

<colgroup><col style="width: 25pxpx" https:="" www.mrexcel.com="" forum="" usertag.php?do="list&action=hash&hash=DAE7F5"" target="_blank"></colgroup><colgroup><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]26[/TD]

</tbody>
Sheet3​
Click to expand...

Dazzawm said:
I am also coming across quite a few with more than 70 characters?
Click to expand...
Can you post a copy of the workbook that is demonstrating these problems to DropBox so I can download it and see how my code is interacting with your actual data?
 
Upvote 0
Do you want it before or after I have run the code?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Lookup PAAF ID based on Worker ID and date range
Replies
3
Views
128
Fluff
Fluff
C
  • Locked
  • Question Question
Tex Split
Replies
4
Views
93
RoryA
RoryA
T
  • Question Question
INDEX and MATCH formula for rainfall cessation
Replies
6
Views
300
Eric W
Eric W
M
  • Solved
VBA Transpose data from one sheet into another
Replies
9
Views
634
madi1004
M
O
  • Solved
Re-arranging structure data and recalculate formulas by add new sheet
2 3
Replies
22
Views
408
Omar M
O

Forum statistics

Threads
1,224,826
Messages
6,181,192
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top