Split excel cell based on its length

[Monty9]

Hello,

I have 3 columns in the excel sheet and I want to split the third column based on the cell's value length (> 40 CHARS) into a new row, but the code should also copy the values of Columns 1 and 2. Example as below;

Initial State:

Column A​	Column B​	Column C ​
Breed	Husky	Siberian Husky is thickly coated dog of medium size and great endurance

After Execution:

Column A​	Column B​	Column C​
Breed	Husky	Siberian Husky is thickly coated dog of
Breed	Husky	medium size and great endurance

It would be great if the code can take care of the entire word to keep Column C cell length <= 40 but otherwise is also ok.

Thank You

 

[Peter_SSs]

Thanks for the additional information and sample data.

Give this a try with a copy of the workbook. For testing, I have the code writing the results to columns M onwards. If it is doing what you want then you could have it over-write the original columns A:K data if you want.

Where rows have data to be split, I have assumed that you want all column A:J repeated for each additional row.

Sub BreakItUp()
  Dim a As Variant, b As Variant
  Dim s As String
  Dim k As Long, i As Long, j As Long, FillCols As Long, uba2 As Long
 
  Const CharsPerLine As Long = 40 '<- Change if required
  
  a = Range("A1:K" & Range("A" & Rows.Count).End(xlUp).Row).Value
  uba2 = UBound(a, 2)
  FillCols = uba2 - 1
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    s = a(i, uba2)
    Do
      k = k + 1
      For j = 1 To FillCols
        b(k, j) = a(i, j)
      Next j
      If InStr(1, s, " ") = 0 Then
          b(k, uba2) = Left(s, CharsPerLine)
          s = Mid(s, CharsPerLine + 1)
      Else
          b(k, uba2) = RTrim(Left(s, InStrRev(s & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
          s = Mid(s, Len(b(k, uba2)) + 2)
      End If
    Loop Until Len(s) = 0
  Next i
  Application.ScreenUpdating = False
  With Range("M1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[Marc L]

I have close to 110K rows to be processed

Column 11 needs Split

As important informations must be in the initial post !​

​

Anyway according to your post #10 sample you should need no more than this :​

Sub Demo2()
  Const C = 11, L = 40
    Dim W, V, N&, R&, S%, P%
        W = [A1].CurrentRegion.Value2
        ReDim V(1 To Rows.Count - 1, 1 To UBound(W, 2))
    For N = 2 To UBound(W)
            R = R + 1
            For S = 1 To UBound(V, 2):  V(R, S) = W(N, S):  Next
        While Len(V(R, C)) > L
            P = InStrRev(V(R, C), " ", L)
            S = P > 0:  If S = 0 Then P = L
            V(R, C) = Left(V(R, C), P + S)
            R = R + 1
            For S = 1 To UBound(V, 2):  V(R, S) = W(N, S):  Next
            V(R, C) = Mid(V(R, C), P + 1)
        Wend
    Next
        [A2].Resize(R, UBound(V, 2)).Value2 = V
End Sub

 

[Monty9]

As important informations must be in the initial post !​

​

Anyway according to your post #10 sample you should need no more than this :​

Sub Demo2()
  Const C = 11, L = 40
    Dim W, V, N&, R&, S%, P%
        W = [A1].CurrentRegion.Value2
        ReDim V(1 To Rows.Count - 1, 1 To UBound(W, 2))
    For N = 2 To UBound(W)
            R = R + 1
            For S = 1 To UBound(V, 2):  V(R, S) = W(N, S):  Next
        While Len(V(R, C)) > L
            P = InStrRev(V(R, C), " ", L)
            S = P > 0:  If S = 0 Then P = L
            V(R, C) = Left(V(R, C), P + S)
            R = R + 1
            For S = 1 To UBound(V, 2):  V(R, S) = W(N, S):  Next
            V(R, C) = Mid(V(R, C), P + 1)
        Wend
    Next
        [A2].Resize(R, UBound(V, 2)).Value2 = V
End Sub

Hello Marc,

I am getting this error;

Maybe, this one will be more helpful;

 

[Monty9]

Thanks for the additional information and sample data.

Give this a try with a copy of the workbook. For testing, I have the code writing the results to columns M onwards. If it is doing what you want then you could have it over-write the original columns A:K data if you want.

Where rows have data to be split, I have assumed that you want all column A:J repeated for each additional row.

Sub BreakItUp()
  Dim a As Variant, b As Variant
  Dim s As String
  Dim k As Long, i As Long, j As Long, FillCols As Long, uba2 As Long
 
  Const CharsPerLine As Long = 40 '<- Change if required
 
  a = Range("A1:K" & Range("A" & Rows.Count).End(xlUp).Row).Value
  uba2 = UBound(a, 2)
  FillCols = uba2 - 1
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    s = a(i, uba2)
    Do
      k = k + 1
      For j = 1 To FillCols
        b(k, j) = a(i, j)
      Next j
      If InStr(1, s, " ") = 0 Then
          b(k, uba2) = Left(s, CharsPerLine)
          s = Mid(s, CharsPerLine + 1)
      Else
          b(k, uba2) = RTrim(Left(s, InStrRev(s & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
          s = Mid(s, Len(b(k, uba2)) + 2)
      End If
    Loop Until Len(s) = 0
  Next i
  Application.ScreenUpdating = False
  With Range("M1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

Hello Peter,

I am getting error for this value (believe i's because of the link)

 

[Peter_SSs]

Hello Peter,

I am getting error for this value (believe i's because of the link)

Yes, try this change

Sub BreakItUp()
  Dim a As Variant, b As Variant
  Dim S As String
  Dim k As Long, i As Long, j As Long, FillCols As Long, uba2 As Long
  
  Const CharsPerLine As Long = 40 '<- Change if required
  
  a = Range("A1:K" & Range("A" & Rows.Count).End(xlUp).Row).Value
  uba2 = UBound(a, 2)
  FillCols = uba2 - 1
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    S = a(i, uba2)
    Do
      k = k + 1
      For j = 1 To FillCols
        b(k, j) = a(i, j)
      Next j
      If InStr(1, S, " ") = 0 Or InStr(1, S, " ") > CharsPerLine + 1 Then
          b(k, uba2) = Left(S, CharsPerLine)
          S = Mid(S, CharsPerLine + 1)
      Else
          b(k, uba2) = RTrim(Left(S, InStrRev(S & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
          S = Mid(S, Len(b(k, uba2)) + 2)
      End If
    Loop Until Len(S) = 0
  Next i
  Application.ScreenUpdating = False
  With Range("M1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[Monty9]

Yes, try this change

Sub BreakItUp()
  Dim a As Variant, b As Variant
  Dim S As String
  Dim k As Long, i As Long, j As Long, FillCols As Long, uba2 As Long
 
  Const CharsPerLine As Long = 40 '<- Change if required
 
  a = Range("A1:K" & Range("A" & Rows.Count).End(xlUp).Row).Value
  uba2 = UBound(a, 2)
  FillCols = uba2 - 1
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    S = a(i, uba2)
    Do
      k = k + 1
      For j = 1 To FillCols
        b(k, j) = a(i, j)
      Next j
      If InStr(1, S, " ") = 0 Or InStr(1, S, " ") > CharsPerLine + 1 Then
          b(k, uba2) = Left(S, CharsPerLine)
          S = Mid(S, CharsPerLine + 1)
      Else
          b(k, uba2) = RTrim(Left(S, InStrRev(S & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
          S = Mid(S, Len(b(k, uba2)) + 2)
      End If
    Loop Until Len(S) = 0
  Next i
  Application.ScreenUpdating = False
  With Range("M1").Resize(k, uba2)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

Hello Peter,

I tried again, this time it is showing this error;

 

[Peter_SSs]

I tried again, this time it is showing this error;

What error?

Could you give us a small set of sample data (with XL2BB would be ideal) that is causing the various issues?

 

[Monty9]

What error?

Could you give us a small set of sample data (with XL2BB would be ideal) that is causing the various issues?

I tried using XL2BB but there are way too many restrictions to load data and also give clarity to you for solving. Instead attaching this drive link to download excel
Test Excel

 

[Peter_SSs]

That's hardly a small sample!

However, try this version. As well as (hopefully) overcoming that last problem, this one tries (not highly tested) to break any hyperlink cells that do not have spaces at appropriate places at a "\" rather than mid-word.

Sub BreakItUp_v2()
  Dim a As Variant, b As Variant
  Dim S As String
  Dim k As Long, i As Long, j As Long, FillCols As Long, uba2 As Long
 
  Const CharsPerLine As Long = 40 '<- Change if required
 
  a = Range("A1:K" & Range("A" & Rows.Count).End(xlUp).Row).Value
  uba2 = UBound(a, 2)
  FillCols = uba2 - 1
  ReDim b(1 To Rows.Count, 1 To uba2)
  For i = 1 To UBound(a)
    S = a(i, uba2)
    Do
      k = k + 1
      For j = 1 To FillCols
        b(k, j) = a(i, j)
      Next j
      If Len(S) <= CharsPerLine Then
        b(k, uba2) = S
        S = ""
      ElseIf InStr(1, S, " ") > 0 And InStr(1, S, " ") < CharsPerLine + 2 Then
        b(k, uba2) = RTrim(Left(S, InStrRev(S & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
        S = Mid(S, Len(b(k, uba2)) + 2)
      ElseIf InStr(2, S, "\") > 1 And InStr(2, S, "\") <= CharsPerLine Then
        b(k, uba2) = Left(S, InStrRev(S, "\", CharsPerLine + 1) + (InStrRev(S, "\", CharsPerLine + 1) = CharsPerLine + 1))
        S = Mid(S, Len(b(k, uba2)) + 1)
      Else
          b(k, uba2) = Left(S, CharsPerLine)
          S = Mid(S, CharsPerLine + 1)
      End If
    Loop Until Len(S) = 0
  Next i
  Application.ScreenUpdating = False
  With Range("M1").Resize(k, uba2)
    .Columns(8).Resize(, 4).NumberFormat = "@"
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[Marc L]

Hello Marc,

I am getting this error;

As I wrote « according to your post #10 sample » so next time link your workbook directly in the initial post !​

​

According to your post #18 attachment my last VBA procedure revamped :​

Sub Demo2r()
  Const C = 11, L = 40
    Dim W, V, N&, R&, S%, P%
        W = [A1].CurrentRegion.Value2
        ReDim V(1 To Rows.Count - 1, 1 To UBound(W, 2))
    For N = 2 To UBound(W)
            R = R + 1
            For S = 1 To UBound(V, 2):  V(R, S) = W(N, S):  Next
        While Len(V(R, C)) > L
            For S = 1 To UBound(V, 2):  V(R + 1, S) = V(R, S):  Next
            P = InStrRev(V(R, C), " ", L)
            S = P > 0:  If S = 0 Then P = L
            V(R, C) = Left(V(R, C), P + S)
            R = R + 1
            V(R, C) = Mid(V(R, C), P + 1)
        Wend
    Next
    If R >= UBound(W) Then
         Application.ScreenUpdating = False
    With [A2].Resize(R, UBound(V, 2))
        .Columns("G:K").NumberFormat = "@"
        .Rows(UBound(W) & ":" & R).Borders.Weight = 2
        .Value2 = V
    End With
         Application.ScreenUpdating = True
    End If
End Sub