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

 

[Marc L]

Hello, a beginner level VBA demonstration :​

Sub Demo1()
      Const C = 40
        Dim R&, T$, P&
        Application.ScreenUpdating = False
    With [A1].CurrentRegion.Rows
        For R = .Count To 1 Step -1
                   T = .Cells(R, 3).Text
            If Len(T) > C Then
               .Item(R)(2).Insert
               .Item(R).Copy .Item(R)(2)
                P = InStrRev(T, " ", C)
               .Cells(R, 3).Value2 = Left(T, P - 1)
               .Cells(R, 3)(2).Value2 = Mid(T, P + 1)
            End If
        Next
    End With
        Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Might the column C text sometimes need to be split into more than two rows of 40 or less characters?

Approximately how many rows of data might there be to process?

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[Marc L]

Might the column C text sometimes need to be split into more than two rows

My beginner level demonstration so easily revamped :​

Sub Demo1r()
      Const C = 40
        Dim R&, T$, P&
        Application.ScreenUpdating = False
    With [A1].CurrentRegion.Rows
        Do
                R = R + 1
                T = .Cells(R, 3).Text
            If Len(T) > C Then
               .Item(R)(2).Insert
               .Item(R).Copy .Item(R)(2)
                P = InStrRev(T, " ", C)
               .Cells(R, 3).Value2 = Left(T, P - 1)
               .Cells(R, 3)(2).Value2 = Mid(T, P + 1)
            End If
        Loop Until R = .Rows.Count
    End With
        Application.ScreenUpdating = True
End Sub

 

[Marc L]

​

Safety correction for the Loop codeline : Loop Until IsEmpty(Cells(R, 1)(2)) …​

 

[Monty9]

My beginner level demonstration so easily revamped :​

Sub Demo1r()
      Const C = 40
        Dim R&, T$, P&
        Application.ScreenUpdating = False
    With [A1].CurrentRegion.Rows
        Do
                R = R + 1
                T = .Cells(R, 3).Text
            If Len(T) > C Then
               .Item(R)(2).Insert
               .Item(R).Copy .Item(R)(2)
                P = InStrRev(T, " ", C)
               .Cells(R, 3).Value2 = Left(T, P - 1)
               .Cells(R, 3)(2).Value2 = Mid(T, P + 1)
            End If
        Loop Until R = .Rows.Count
    End With
        Application.ScreenUpdating = True
End Sub

Is it possible to add FORCED SPLIT as well, since I have hyper links at some cells and they don't have spaces between them?

 

[Peter_SSs]

Thanks for updating your profile for version info.

BTW, what are the answers to my two questions?

 

[Marc L]

Is it possible to add FORCED SPLIT as well, since I have hyper links at some cells and they don't have spaces between them?

My revamped demonstration revamped :​

Sub Demo1r2d2()
      Const C = 40
        Dim R&, T$, P%, S%
        Application.ScreenUpdating = False
    With [A1].CurrentRegion.Rows
        Do
                R = R + 1
                T = .Cells(R, 3).Text
            If Len(T) > C Then
               .Item(R)(2).Insert
               .Item(R).Copy .Item(R)(2)
                P = InStrRev(T, " ", C)
                S = P > 0:  If S = 0 Then P = C
               .Cells(R, 3).Resize(2).Value2 = Evaluate("{""" & Left(T, P + S) & """;""" & Mid(T, P + 1) & """}")
            End If
        Loop Until R = .Rows.Count
    End With
        Application.ScreenUpdating = True
End Sub

 

[Monty9]

Thanks for updating your profile for version info.

BTW, what are the answers to my two questions?

Yes Sir, here they are,

Might the column C text sometimes need to be split into more than two rows of 40 or less characters? - Yes, there are some cases where data in cell is more than 80 chars

Approximately how many rows of data might there be to process? - I have close to 110K rows to be processed

Thanks

 

[Monty9]

My revamped demonstration revamped :​

Sub Demo1r2d2()
      Const C = 40
        Dim R&, T$, P%, S%
        Application.ScreenUpdating = False
    With [A1].CurrentRegion.Rows
        Do
                R = R + 1
                T = .Cells(R, 3).Text
            If Len(T) > C Then
               .Item(R)(2).Insert
               .Item(R).Copy .Item(R)(2)
                P = InStrRev(T, " ", C)
                S = P > 0:  If S = 0 Then P = C
               .Cells(R, 3).Resize(2).Value2 = Evaluate("{""" & Left(T, P + S) & """;""" & Mid(T, P + 1) & """}")
            End If
        Loop Until R = .Rows.Count
    End With
        Application.ScreenUpdating = True
End Sub

Hello Marc,

I tried this code on the actual data by changing Column values from 3 to 11 (Column 11 needs Split), here I am getting error while splitting (attached data for your test). I am getting #VALUE in some of the cells while others are getting splitted nicely.

Task Type	Group Number	Group Counter	Task Node	Int. Counter	Lineno	Lang	Tag	Functional Location	Equipment	Text Line
A	7520​	1​		1​	1​	EN	*			DAN01 - Replace Flammable Off-load fire pit pump. Coupling has dropped
A	7520​	1​		1​	2​	EN	*			down, looks like whole shaft might have dropped down. Pump is all rusted
A	7520​	1​		1​	3​	EN	*			out.
A	7520​	1​		1​	4​	EN	*
A	7520​	1​		1​	5​	EN	*			* Old pump to be placed in metal dumpster.
A	7520​	1​		1​	6​	EN	*
A	7520​	1​		1​	7​	EN	*			Pump needs to be replaced. 5/2/2019 DH
A	7520​	1​		1​	8​	EN	*
A	7520​	1​		1​	9​	EN	*			* Quote for pump is attached to the PMO. MRO to order pump
A	7520​	1​		1​	10​	EN	*			**DAIN TO GO GET PIPE AND VALVE PRIOR TO STARTING**
A	7520​	1​		1​	11​	EN	*
A	7520​	1​		1​	12​	EN	*			*** MATERIAL ***
A	7520​	1​		1​	13​	EN	*
A	7520​	1​		1​	14​	EN	*			(1) ORDER VERTICAL SUMP PUMP PER QUOTE: RGG042619-1 FROM NIS
A	7520​	1​		1​	15​	EN	*			2" 2579-8S E.C. Schleyer Vertical Sump Pump
A	7520​	1​		1​	16​	EN	*			120" Setting in all iron construction W/ SS Shaft
A	7520​	1​		1​	17​	EN	*			Carbon Graphite bearings complete with coupling and Guard
A	7520​	1​		1​	18​	EN	*			PRICE: $8550.00
A	7520​	1​		1​	19​	EN	*			****MILLRIGHT IF PUMP NEEDS ADJUSTED TO SET LIFT IT IS A QUATER TURN ON
A	7520​	1​		1​	20​	EN	*			THE TOP NUT TO RAISE*****
A	7520​	1​		1​	21​	EN	*
A	7520​	1​		1​	22​	EN	*
A	7520​	1​		1​	23​	EN	*