1细胞分裂成4细胞VBA

Question

此代码正在工作，请在下面找到我需要分割的前后数据，根据标准，第一列数据将为6 chr，第2列为5 chr，第3列为4 chr，第4列为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: " & Err.Number & " " & Err.Description

End Sub

Answer 1

我终于找到了有用的东西。

请注意，您需要将类模块重命名为productCode才能实际工作。

正则模块

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

类模块

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

Answer 2

一些一般性的想法，首先，但不完全了解你的标准：

使用数组，而不是范围。

根据变量的函数命名变量，要精确地命名

• CellInfo => CellContentLength，LengthOfCellText .
• mergedCells => CellsToSplit
• cellRow => CurrentCell .