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

 

[Dazzawm]

Any thoughts anyone please?

 

[MickG]

Try this for data in column "B" starting "B2".

[COLOR="Navy"]Sub[/COLOR] MG18Jul48
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ray, Sp [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
    Sp = Split(Dn.Value, "/ ")
    ReDim Ray(1 To UBound(Sp))
    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
       nLen = nLen + Len(Sp(n))
        [COLOR="Navy"]If[/COLOR] nLen > 70 [COLOR="Navy"]Then[/COLOR]
            nLen = Len(Sp(n))
            c = c + 1
            Ray(c) = nStr
            nStr = Sp(n)
        [COLOR="Navy"]Else[/COLOR]
            nStr = nStr & IIf(nStr = "", Sp(n), "/ " & Sp(n))
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
    
    [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"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Dazzawm]

Thanks Mick but I get a subscript out of range. I think it may be because it has come across a single number in a cell with no '/' like [TABLE="width: 428"]
<tbody>[TR]
[TD="class: xl63, width: 428"]60694260?[/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG18Jul40
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ray, Sp [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
    Sp = Split(Dn.Value, "/ ")
    [COLOR="Navy"]If[/COLOR] UBound(Sp) = 0 [COLOR="Navy"]Then[/COLOR]
        Dn.Offset(, 1).Value = Dn
    [COLOR="Navy"]Else[/COLOR]
        ReDim Ray(1 To UBound(Sp))
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                nLen = nLen + Len(Sp(n))
                [COLOR="Navy"]If[/COLOR] nLen > 70 [COLOR="Navy"]Then[/COLOR]
                    nLen = Len(Sp(n))
                         c = c + 1
                        Ray(c) = nStr
                        nStr = Sp(n)
                [COLOR="Navy"]Else[/COLOR]
                        nStr = nStr & IIf(nStr = "", Sp(n), "/ " & Sp(n))
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] n
    
            [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"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Dazzawm]

Sorry Mick could you also add in the code to remove any duplicates that may be in a cell as I just noticed that is possible i.e 12345/ 12345? So only one needed. Thanks.

 

[MickG]

Try this:-

[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

 

[Dazzawm]

Thanks Mick but it doesn't seem to remove the duplicates?

 

[Dazzawm]

Forget that Mick was looking at wrong column. Works great thanks.

 

[MickG]

You're welcome