Splitting 1 cell into 4 cells VBA

Question

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.

Data example

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: " & Err.Number & " " & Err.Description
End Sub

• Máté Juhász: "1st column with data will be 6 chr, 2nd column 5 chr, 3rd column 4 chr, 4th column 2 chr" - your code is much more complicated, please elaborate a bit what are the rules of spliting the data, it's difficult to follow now.
• QuickSilver: @MátéJuhász The criteria is 1st column will require having 6 chr from the full string in the cell 2nd column will have the next 5 chr from the cell 3rd column will have the next 4 chr from the cell and the 4th will have the last 2 chr from the cell ignoring any symbols. For my code, I used the macro recorder to get the code from the text to column and see how it was doing the splitting. I don't really know if the above can be done other way as I am still learning towards becoming a developer still the early stages of learning. Any help will be much appreciated.

Answer 1

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, ...

• QuickSilver: Juhasz Noted will change code as soon as possible, thank you very much for your comments.

Answer 2

I took a somewhat different approach to your data conversion, choosing to split the strings without relying on Excel worksheet functions. Instead, taking @MátéJuhász excellent advice on using memory-based array rather than ranges. You'll see I've separated the problem into two parts in order to gain some independence in how (and where) the solution is applied.

First, in order to process the source data range and produce the results, it's easy to see that the source data can change every time you run the macro. For this reason, separate how you determine the source range from the actual data-split processing. I accomplish this in a simple test function. Note that you can still require your user to Select the range by hand if you like. But it really doesn't matter because the later processing doesn't care.

Option Explicit
Sub test()
 Dim wb As Workbook
 Dim ws As Worksheet
 Set wb = ThisWorkbook
 Set ws = wb.Sheets("Sheet1")
 Dim srcArea As Range
 Set srcArea = ws.Range("D1:D3")
 Dim dstArea As Range
 Set dstArea = ws.Range("D6")
 Dim results As Variant 'array of split data
 results = SplitSourceData(srcArea)
 Set dstArea = dstArea.Resize(UBound(results, 1), 4)
 dstArea = results
End Sub

Next, for the major part of the work is the SplitSourceData function which accepts as an input parameter the srcData as Range and returns a memory-based array of the split results.

As mentioned in the other answer, it's best to use descriptive names for the variables. This will tremendously help you keep track of what you're doing and how you're doing it. The heavy lifting of the function is set up by choosing the positions and lengths of the data, according to the original string length. I've provided a start for three of the lengths, so you need to fill in the rest.

'--- starting positions for substrings
Dim stylePos As String
Dim fabricPos As String
Dim colourPos As String
Dim sizePos As String
'--- lengths of substrings
Dim styleLen As Long
Dim fabricLen As Long
Dim colourLen As Long
Dim sizelen As Long

Copying your source data from the Worksheet.Range to a memory-based array is straightforward, as is setting up the destination array for the results:

'--- copy source data to memory-based array
Dim i As Long
Dim src As Variant
src = srcData

EDIT: the original example simply performed a ReDim on dst variable to get a new array, sized by "n" rows and 4 columns. While this seems to work on some Excel installations, this type of ReDim is explicitly not allowed by VBA when the first dimension is changed. Since we need the array size to match a (eventual) destination Range, resizing the first dimension is required. So my hack to get an appropriately sized array is to create a Resized Range (in an unused area of the worksheet to guarantee it's blank/empty), then copy that range into waiting Variant. This creates the properly sized array:

Dim blankArea As Range
Set blankArea = ActiveSheet.Range("ZZ1").Resize(UBound(src, 1), 4)
Dim dst As Variant
dst = blankArea

Especially since you have a large number of potential string formats, it's easier to organize if you use a Select statement to determine where all the data is:

Select Case Len(src(i, 1))
Case 15
 fabricPos = 7
 fabricLen = 4
 colourPos = 12
 colourLen = 4
 sizePos = 1
 sizelen = 0 'no size in this data
Case 21
 fabricPos = 7
 fabricLen = 4
 colourPos = 13
 colourLen = 4
 sizePos = 20
 sizelen = 2

The rest of the function uses the string function Mid separate the data according to the format parameters. The resulting array is then returned.

Hopefully this example can help you understand how to organize your code a bit differently and use more of the language to get things done.

Here's the full test method and function:

Option Explicit
Sub test()
 Dim wb As Workbook
 Dim ws As Worksheet
 Set wb = ThisWorkbook
 Set ws = wb.Sheets("Sheet1")
 Dim srcArea As Range
 Set srcArea = ws.Range("D1:D3")
 Dim dstArea As Range
 Set dstArea = ws.Range("D6")
 Dim results As Variant 'array of split data
 results = SplitSourceData(srcArea)
 '--- define where the results go, based on the size that comes back
 Set dstArea = dstArea.Resize(UBound(results, 1), 4)
 dstArea = results
End Sub
Function SplitSourceData(srcData As Range) As Variant
 '--- starting positions for substrings
 Dim stylePos As String
 Dim fabricPos As String
 Dim colourPos As String
 Dim sizePos As String
 '--- lengths of substrings
 Dim styleLen As Long
 Dim fabricLen As Long
 Dim colourLen As Long
 Dim sizelen As Long
 '--- copy source data to memory-based array
 Dim i As Long
 Dim src As Variant
 src = srcData
 '--- set up memory-based destination array
 ' Excel does not allow resizing the first dimension of a
 ' multi-dimensional array, so we'll cheat a little and
 ' create a Range with the sized dimensions we need (in an
 ' unused area of the Worksheet), then pull that in as the
 ' 2D array size we need
 Dim blankArea As Range
 Set blankArea = ActiveSheet.Range("ZZ1").Resize(UBound(src, 1), 4)
 Dim dst As Variant
 dst = blankArea
 '--- these positions and lengths seems fixed for every
 ' possible format, so no need to reset them for each loop
 stylePos = 1
 styleLen = 6
 For i = 1 To UBound(src)
 '--- decomposition formats determined by data length
 Select Case Len(src(i, 1))
 Case 15
 fabricPos = 7
 fabricLen = 4
 colourPos = 12
 colourLen = 4
 sizePos = 1
 sizelen = 0 'no size in this data
 Case 21
 fabricPos = 7
 fabricLen = 4
 colourPos = 13
 colourLen = 4
 sizePos = 20
 sizelen = 2
 Case 22
 fabricPos = 8
 fabricLen = 4
 colourPos = 14
 colourLen = 4
 sizePos = 21
 sizelen = 2
 Case Else
 Debug.Print "undefined data length in row " & i & ", len=" & Len(src(i, 1))
 End Select
 dst(i, 1) = Mid(src(i, 1), stylePos, styleLen)
 dst(i, 2) = Mid(src(i, 1), fabricPos, fabricLen)
 dst(i, 3) = Mid(src(i, 1), colourPos, colourLen)
 dst(i, 4) = Mid(src(i, 1), sizePos, sizelen)
 Next i
 SplitSourceData = dst 'return the destination array
End Function

• QuickSilver: This is so advanced stuff it's to early for me to do this kind of things amazing thank you again for your help. Just one thing that i can't make it to run because it gives me type mismatch at the ReDim dst(1 To UBound(src), 1 To 4) 'n rows by 4 columns line and can't work it out why. Will try to figure it out by researching online thank you for your help.
• QuickSilver: For some reason, I managed to make it work on my mac and didn't do anything i don't know why the excel on windows is giving me type mismatch on the ReDim dst line will try over the weekend to see what i can change to make it work don't know if the version of excel has something to do with i use Excel 2007. Will keep you posted if i can make it work on windows. But on the mac works amazing so i think it should work maybe i'm doing something wrong on windows.
• PeterT: See the edited code above, with the explanation on how I fixed the array ReDim. This should work for you.
• QuickSilver: Thank you for your help now it works perfectly. I will get back to you in the weekend so i can do extensive testing for it and then i will try to convert to use the user 'Selections' the data range as thee will be at one given time maybe 10 rows to convert at a time so it makes sense to use the selection for this. Again thank you will you use the same procedure to merge 3 cells in one so basically concatenating 3 cells in one? Will you use the same approach?
• QuickSilver: To merge 3 cells into one in the above table example to recreate the full length string would you use the same approach??? Obviously the string length is known to be exactly 15 characters when merged together but what will be the best way in terms of speed to do this?

Answer 3

I finally got something that actually works.

Please note that you need to rename the Class Module to productCode to actually work.

Regular Module

Option Explicit
Sub splitStyleFabricColourSizeV3()
 'Please note you need to add a references to Microsoft VBScript Regular Expession 5.5
 Dim wsSrc As Worksheet, wsRes As Worksheet
 Dim vSrc As Variant, vRes As Variant, rRes As Range
 Dim RE As Object, MC As Object
 Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
 'Group 1 = style
 'Group 2 = fabric
 'Group 3 = colour
 'Group 4 = size
 Dim colF As Collection, pC As productCode
 Dim I As Long
 Dim S As String
 Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveSheet
Set wsRes = ActiveSheet
 Set rRes = wsRes.Application.Selection
'Read source data into array
vSrc = Selection.Resize(columnsize:=4)
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
 .Global = False
 .MultiLine = True
 .Pattern = sPat
'Test for single cell
If Not IsArray(vSrc) Then
 V = vSrc
 ReDim vSrc(1 To 1, 1 To 1)
 vSrc(1, 1) = V
End If
 'iterate through the list
For I = 1 To UBound(vSrc, 1)
 S = vSrc(I, 1)
 Set pC = New productCode
 If .test(S) = True Then
 Set MC = .Execute(S)
 With MC(0)
 pC.Style = .submatches(0)
 pC.Fabric = .submatches(1)
 pC.Colour = .submatches(2)
 pC.Size = .submatches(3)
 End With
 ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
 pC.Style = S
 Else
 pC.Style = vSrc(I, 1)
 pC.Fabric = vSrc(I, 2)
 pC.Colour = vSrc(I, 3)
 pC.Size = vSrc(I, 4)
 End If
 colF.Add pC
Next I
End With
'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate the rest
I = 0
For Each V In colF
 I = I + 1
 With V
 vRes(I, 1) = .Style
 vRes(I, 2) = .Fabric
 vRes(I, 3) = .Colour
 vRes(I, 4) = .Size
 End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
 rRes.Value = vRes
End Sub

Class Module

Option Explicit
'Rename this Class Module productCode
Private pStyle As String
Private pFabric As String
Private pColour As String
Private pSize As String
Public Property Get Style() As String
 Style = pStyle
End Property
Public Property Let Style(Value As String)
 pStyle = Value
End Property
Public Property Get Fabric() As String
 Fabric = pFabric
End Property
Public Property Let Fabric(Value As String)
 pFabric = UCase(Value)
End Property
Public Property Get Colour() As String
 Colour = pColour
End Property
Public Property Let Colour(Value As String)
 pColour = Value
End Property
Public Property Get Size() As String
 Size = pSize
End Property
Public Property Let Size(Value As String)
 pSize = Value