Question

以下代码将根据6chr，5chr，4chr，5 + chr的模式将1个单元格拆分为3或4列。以下内容也需要在所有打开的工作簿上提供，并根据用户选择进行操作。

如何修复在第一次拆分单元格之后再次运行它会覆盖数据的错误？

课程模块

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

常规模块

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

上述内容归@Ron Rosenfeld所有！

Answer 1

忽略以前的正则表达式/类方法，

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

判断该条目之前是否已拆分的一种方法如下

如果regex.test失败，那么
- 如果结果行通过，则该项目先前已拆分
- 如果没有，那么它是空白或格式错误的条目

请注意，如果您没有覆盖原始数据，可以避免很多这种情况。我建议不要为了审计和调试目的而覆盖你的数据，但如果你不能改变它，下面应该有所帮助。

您只需要在我们最初检查格式错误的条目的逻辑中进行一些小的更改。除了阅读＆＃34;可能＆＃34;结果数组到vSrc中，以便我们有可能的拆分数据进行比较：

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

Answer 3

在输出到电子表格的代码中，您需要检查空字符串

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

如何阻止第二次运行代码以防止覆盖数据regex vba？

3 个答案: