用VBA将1个细胞分成3个和4个细胞

Question

以下代码将数据从1个单元格拆分为数组中的3个或4个单元格。我遇到的问题是，当数据没有落入任何一种情况时，它有时会开始按其中一种情况分裂，有时如果它低于15种字符。然后，如果你再次运行并且只找到6 chr，它将在单元格1中写入6 chr，然后如果第一次完成拆分并且数据正确，则第二次运行将覆盖并放置空单元格。如果完成拆分，则无法解决如何解决此问题，然后忽略所选择的内容以及在任何情况下都不会忽略单元格并移动到下一个。

   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

我会使用正则表达式来获取值。我还将创建一个Class对象来处理数据。类对象的属性将是您要查找的项目。我们将所有类对象收集到一个集合中;然后输出结果是微不足道的。

编辑：

• 正则表达式已更正为允许可选尺寸参数。
• 如果零匹配，则测试添加到退出宏。
• 添加测试以检查是否只有一行要拆分

我根据您的代码和示例来定义字段定义。因此，如果它们并非全部包含在内，请回复“失败”。

使用类可以使例程更加自我记录，并使未来的修改更容易

请务必按照评论

中的说明重命名Class模块

班级单元

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

正则表达式解释

^ \ S * \ S *（{6}）。（{5}。）（{4}。）（？：* 1 /（\ S +））？

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

选项：区分大小写; ^ $匹配在换行

• 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) +

使用RegexBuddy

创建

Answer 2

似乎您可以通过删除额外部分和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

我没有excel-vba专家，但我确信在case else情况下，我仍然会根据 Pos 和 Len 值从上一行遗留下来。也就是说，当你遇到一个未定义长度的行时，它将打印你的警告（拼写错误，顺便说一句），然后继续并执行dst(1, n) =行。此时，将使用上一次迭代中StylePos，StyleLen等中的任何内容。

至少有两种方法可以解决这个问题。首先，您可以将goto nextDataSource放在Case Else块中。这将跳过 dst 的加载。

另一种选择是向errFlag = 1添加Case Else之类的内容，然后围绕 dst 的负载进行测试：

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

当然，不要忘记在Select Case语句之前将errFlag设置为0。

希望这有帮助！

Answer 4

  

^{我在等待评论的答案时写了这篇文章。 Ron Rosenfeld最近的基于正则表达式的答案比这更彻底，但是我发布它以防你想要创建一个函数而不是一个子程序。这里使用的正则表达式.Pattern基于您的原始样本数据，不适用于您的新样本数据（我无意在任何情况下重新输入）}

使用基于正则表达式文本解析的用户定义函数来拆分第一组小写字母。之后，任何位于另一个占位符中的东西都只能是一个字符。

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