Split 1 cell into 3 and 4 cells with VBA

Question

The below code splits the data from 1 cell into 3 or 4 cells from a array. The problem that I have with it is when the data doesn't fall into any of the cases sometimes it starts splitting by one of the cases and sometimes if it's below the 15 characters. Then if you run it again and finds only 6 chr it will write the 6 chr in cell 1 and then if the split was done first time and data is correct second time it runs will override and put empty cells instead. Can't work out how to solve this problem if the split was done then ignore what is selected and if it doesn't fall in any of the cases ignore cell and move to the next.

   Sub splitText()
       Dim wb As Workbook
       Dim Ws As Worksheet
       Set wb = ThisWorkbook
       Set Ws = ActiveSheet

       Dim srcArea As Range
       Set srcArea = Selection

       Dim dstArea As Range
       Set dstArea = Selection

       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 = 5
               colourPos = 12
               colourLen = 4
               sizePos = 1
               sizelen = 0   'no size in this data
           Case 20
               fabricPos = 7
               fabricLen = 5
               colourPos = 12
               colourLen = 4
               sizePos = 19
               sizelen = 2
           Case 21
               fabricPos = 7
               fabricLen = 5
               colourPos = 12
               colourLen = 4
               sizePos = 19
               sizelen = 3
           Case 22
               fabricPos = 8
               fabricLen = 5
               colourPos = 14
               colourLen = 4
               sizePos = 21
               sizelen = 2
           Case Else
               Debug.Print "Worning! 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)
   nextDataSource:
       Next i
       SplitSourceData = dst   'return the destination array

   End Function

Answer 1

I would use a Regular Expression to get the values. I would also create a Class object to handle the data. The properties of the class object will be the items you are looking for. We gather all the class objects into a collection; then outputting the results is trivial.

EDIT:

• Regex corrected to allow for optional size parameter.
• Test added to exit macro if zero matches.
• Test added to check for just a single line to be split

I based the field definitions on your code and examples. So if they are not all inclusive, post back with "failures".

Using a class lets the routine be more self-documenting, and also makes future modifications easier

Be sure to rename the Class module as noted in the comments

Class Module

Option Explicit
'Rename this Class Module  cFabric
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
End Property

Regular Module

Option Explicit
Sub Fabrics()
    'assume data is in column A
    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, cF As cFabric
    Dim I As Long
    Dim S As String
    Dim V As Variant

'Set source and results worksheets and ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 3)

'Read source data into array
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'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

    'iterate through the list

'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

For I = 1 To UBound(vSrc, 1)
    S = vSrc(I, 1)
    Set cF = New cFabric
    If .test(S) = True Then
        Set MC = .Execute(S)
        With MC(0)
            cF.Style = .submatches(0)
            cF.Fabric = .submatches(1)
            cF.Colour = .submatches(2)
            cF.Size = .submatches(3)
        End With
    Else
        cF.Style = S
    End If
    colF.Add cF
Next I
End With

'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub

ReDim vRes(0 To colF.Count, 1 To 4)

'headers
vRes(0, 1) = "Style"
vRes(0, 2) = "Fabric"
vRes(0, 3) = "Colour"
vRes(0, 4) = "Size"

'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) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .NumberFormat = "@"
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

Regex Explanation

^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?

^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?

Options: Case sensitive; ^$ match at line breaks

• Assert position at the beginning of a line ^
• Match the regex below and capture its match into backreference number 1 (.{6})
  • Match any single character that is NOT a line break character .{6}
    • Exactly 6 times {6}
• Match a single character that is a “whitespace character” \s*
  • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
• Match the regex below and capture its match into backreference number 2 (.{5})
  • Match any single character that is NOT a line break character .{5}
    • Exactly 5 times {5}
• Match a single character that is a “whitespace character” \s*
  • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
• Match the regex below and capture its match into backreference number 3 (.{4})
  • Match any single character that is NOT a line break character .{4}
    • Exactly 4 times {4}
• Match the regular expression below (?:.*1/(\S+))?
  • Between zero and one times, as many times as possible, giving back as needed (greedy) ?
  • Match any single character that is NOT a line break character .*
    • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
  • Match the character string “1/” literally 1/
  • Match the regex below and capture its match into backreference number 4 (\S+)
    • Match a single character that is NOT a “whitespace character” \S+
      • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +

Created with RegexBuddy

Answer 2

Seems like you can just normalize the data by removing the extra parts and split by fixed widths:

Dim r As Range
Set r = Cells.CurrentRegion

r.Replace " - 1/", ""
r.Replace " 1/", ""
r.Replace " ", ""

r.TextToColumns r, xlFixedWidth, FieldInfo:=[{0,1;6,1;11,1;15,1}]
r.CurrentRegion.HorizontalAlignment = xlCenter

Answer 3

^{I wrote this while waiting for an answer to a comment. Ron Rosenfeld's recent regex-based answer is much more thorough than this but I'm posting it in case you want some direction in creating a function rather than a sub procedure. The regex .Pattern used here was based on your original sample data and will not work on your newer sample data (which I have no intention of retyping in any event)}

Use a User Defined Function based on Regular Expression text parsing to split off the first set of lower case letters. After that, anything that is located as another placeholder to split on is only a single character.

Option Explicit

Function explodePieces(str As String, Optional ndx As Long = 1)
    Dim i As Long, result As Variant
    Static cmat As Object, regex As Object

    ReDim result(1 To 4)
    result(1) = str
    If regex Is Nothing Then
        Set regex = CreateObject("VBScript.RegExp")
        With regex
            .Global = False
            .MultiLine = False
            .IgnoreCase = False
        End With
    Else
        Set cmat = Nothing
    End If

    With regex
        .Pattern = "[a-z]{3}"
        If regex.Test(str) Then
            Set cmat = .Execute(str)
            result(1) = Split(str, cmat.Item(cmat.Count - 1))(0)
            result(2) = cmat.Item(cmat.Count - 1)
            Select Case ndx
                Case 1, 2
                    'nothing more to do
                Case 3, 4
                    result(3) = Split(str, cmat.Item(cmat.Count - 1))(1)
                    i = InStrRev(result(3), Chr(47))
                    If CBool(i) Then
                        i = InStrRev(result(3), Chr(32), i)
                        result(4) = Mid(result(3), i)
                        result(3) = Trim(Replace(result(3), result(4), vbNullString))

                    End If
            End Select
            explodePieces = Replace(Replace(result(ndx), Chr(32), vbNullString), Chr(45), vbNullString)
        End If
    End With

End Function

Answer 4

I'm no excel-vba expert, but it sure looks to me like in the case else situation, it still loads your destination cells with values, based on whatever Pos and Len values were left over from the previous row. That is, when you hit a row with an undefined length, it will print your warning (which is misspelled, btw), and then continue on and execute the dst(1, n) = lines. At that point, whatever was in StylePos, StyleLen, etc. from the previous iteration will be used.

There are at least two ways to solve this. First, you can put goto nextDataSource inside the Case Else block. That will skip the loading of dst.

The other option is to add something like errFlag = 1 to the Case Else and then put a test around the load of dst:

if (errFlag = 0) then
   dst(i, 1) = Mid...
End if

Don't forget, of course, to set errFlag to 0 right before the Select Case statement.

Hope this helps!