Splitting 1 cell into 4 cells VBA This code is working, please find below the before and after data that i need to split as per criteria 1st column with data will be 6 chr, 2nd column 5 chr, 3rd column 4 chr, 4th column 2 chr.



Sub splitStyleFabricColourSize()

Dim cellRow As Range
Dim mergedCells As Range
Dim cellInfo As Long

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set mergedCells = Selection

For Each cellRow In mergedCells.Cells
cellRow.Select

cellInfo = ActiveCell.Characters.Count
Debug.Print cellInfo

If cellInfo = 15 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1))

ElseIf cellInfo = 17 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array(12, 9), Array(13, 1))

ElseIf cellInfo = 18 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(8, 1), Array(13, 9), Array(14, 1))

ElseIf cellInfo = 22 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array(12, 9), Array(13, 1), _
        Array(17, 9), Array(20, 1))

ElseIf cellInfo = 23 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array(12, 9), Array(13, 1), _
        Array(17, 9), Array(21, 1))

ElseIf cellInfo = 24 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
        OtherChar:="/", FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array(12, _
        9), Array(13, 1), Array(17, 9), Array(22, 1))


ElseIf cellInfo = 25 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , OtherChar:="/", FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array( _
        12, 9), Array(13, 1), Array(17, 9), Array(23, 1))

ElseIf cellInfo = 26 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , OtherChar:="/", FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array( _
        12, 9), Array(13, 1), Array(17, 9), Array(22, 1))

ElseIf cellInfo = 27 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , OtherChar:="/", FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(8, 1), Array( _
        13, 9), Array(14, 1), Array(18, 9), Array(23, 1))

ElseIf cellInfo = 29 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
        OtherChar:="/", FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(8, 1), Array(13, _
        9), Array(14, 1), Array(18, 9), Array(25, 1))

ElseIf cellInfo = 52 Then
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth _
        , FieldInfo:=Array(Array(0, 1), Array(6, 9), Array(7, 1), Array(12, 9), Array(13, 1), _
        Array(17, 9), Array(20, 1), Array(42, 9))

End If

Next cellRow
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Exit Sub
ErrorHandler:
Debug.Print "Error number: " &amp; Err.Number &amp; " " &amp; Err.Description

End Sub
Some general ideas first, without fully understanding your criteria:

Work with arrays, not with ranges

name the variables according to their function, be precise


CellInfo => CellContentLength, LengthOfCellText, ...
mergedCells => CellsToSplit
cellRow => CurrentCell, ...