2
\$\begingroup\$

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
\$\endgroup\$
2
  • \$\begingroup\$ "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. \$\endgroup\$ Apr 3 '17 at 11:57
  • \$\begingroup\$ @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. \$\endgroup\$ Apr 3 '17 at 21:16
2
\$\begingroup\$

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, ...
\$\endgroup\$
1
  • \$\begingroup\$ Juhasz Noted will change code as soon as possible, thank you very much for your comments. \$\endgroup\$ Apr 3 '17 at 21:18
1
\$\begingroup\$

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
\$\endgroup\$
9
  • \$\begingroup\$ 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. \$\endgroup\$ Apr 4 '17 at 20:15
  • \$\begingroup\$ 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. \$\endgroup\$ Apr 4 '17 at 22:25
  • \$\begingroup\$ See the edited code above, with the explanation on how I fixed the array ReDim. This should work for you. \$\endgroup\$
    – PeterT
    Apr 5 '17 at 15:42
  • \$\begingroup\$ 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? \$\endgroup\$ Apr 5 '17 at 22:03
  • \$\begingroup\$ 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? \$\endgroup\$ Apr 7 '17 at 20:09
0
\$\begingroup\$

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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.