How to stop second run of the code to prevent over

Question

The below code will split 1 cell into 3 or 4 column based on a pattern of 6chr,5chr,4chr,5+chr. The below also needs to be available on all open workbooks and work from the user selection.

How to fix a bug that after the first splitting of the cell is done and by mistake you run it again will override the data?

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()

    Dim wsSrc As Workbook, wsRes As Workbook
    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 = ActiveWorkbook
Set wsRes = ActiveWorkbook
    Set rRes = wsRes.Application.Selection

'Read source data into array
vSrc = Application.Selection

'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 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 no 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

Credits for the above goes to @Ron Rosenfeld for the project!

Answer 1

Disregarding the previous regex/class method,

Option Explicit

Sub Fabrics_part_Deux()
    Dim a As Long, b As Long

    With Worksheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3))
            With .Columns("B")
                .Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart
            End With
            .AutoFilter field:=2, Criteria1:="<>"
            .AutoFilter field:=3, Criteria1:=""
            With .Resize(.Rows.Count - 1, 1).Offset(1, 1)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    With .SpecialCells(xlCellTypeVisible)
                        For a = 1 To .Areas.Count
                            With .Areas(a).Cells
                                .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
                                    FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2))
                                For b = 1 To .Rows.Count
                                    .Cells(b, 2) = UCase$(.Cells(b, 2).Value2)
                                    If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then
                                        .Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1))
                                    End If
                                Next b
                            End With
                        Next a
                    End With
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
End Sub

Answer 2

In your code to output to the spreadsheet, you need to check for empty strings

I = 0
For Each V In colF
    I = I + 1
    With V
        vRes(I, 1) = .Style
        If len(.Fabric) > 0 then
            vRes(I, 2) = .Fabric
            vRes(I, 3) = .Colour
            vRes(I, 4) = .Size
        End If
    End With
Next V

Answer 3

One way to tell if the entry has been previously split is as follows

• If the regex.test fails, then
  • If the results line passes, then the item has been previously split
  • if not, then it is a blank, or a malformed entry

Note that a lot of this could be avoided if you were not overwriting your original data. I would recommend against overwriting your data both for audit and debugging purposes, but the below should help in case you cannot change that.

You just need to make some small changes in the logic where we checked for the malformed entry originally. As well as reading in the "possible" results array into vSrc so that we have the potentially split data to compare:

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 = ActiveSheet
Set wsRes = ActiveSheet
    Set rRes = 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

    '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

    ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
        cF.Style = S
    Else
        cF.Style = vSrc(I, 1)
        cF.Fabric = vSrc(I, 2)
        cF.Colour = vSrc(I, 3)
        cF.Size = vSrc(I, 4)
    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(1 To colF.Count, 1 To 4)

'Populate
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))
With rRes
    .Clear
    .NumberFormat = "@"
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub