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

Question

下面的代码将数据从一个单元格拆分为一个数组中的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对象来处理数据。类对象的属性将是要查找的项。我们将所有的类对象收集到一个集合中，然后输出结果非常简单。

编辑：

• Regex修正为允许可选的大小参数。
• 测试添加到退出宏，如果零匹配。
• 添加测试，以检查是否只拆分一行

我的字段定义基于您的代码和示例。因此，如果它们不是全部都包含在内，就用“失败”回发。

使用类可以使例程更自文档化，并使将来的修改更容易。

确保重命名类模块，如注释中所述

类模块

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

Regex解释

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

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

选项:区分大小写；^$Options在划线处匹配

• 在行的开头断言位置 ^
• 匹配下面的正则表达式，并将其匹配捕获到反向引用编号1中。 (.{6})
  • 匹配任何不是换行字符的单个字符。 .{6}
    • 整整6次 {6}

​

​

• 匹配“空格字符”的单个字符 \s*
  • 在零和无限倍之间，尽可能多次，按需要回馈(贪婪) *

​

• 匹配下面的正则表达式，并将其匹配捕获到反向引用编号2中。 (.{5})
  • 匹配任何不是换行字符的单个字符。 .{5}
    • 整整5次 {5}

​

​

• 匹配“空格字符”的单个字符 \s*
  • 在零和无限倍之间，尽可能多次，按需要回馈(贪婪) *

​

• 匹配下面的regex并将其匹配捕获到反向引用号3中。 (.{4})
  • 匹配任何不是换行字符的单个字符。 .{4}
    • 整整4次 {4}

​

​

• 匹配下面的正则表达式 (?:.*1/(\S+))?
  • 在0到1倍之间，尽可能多次，按需要回馈(贪婪) ?
  • 匹配任何不是换行字符的单个字符。 .*
    • 在零和无限倍之间，尽可能多次，按需要回馈(贪婪) *

​

- [Match the character string “1/” literally](http://www.regular-expressions.info/characters.html) `1/`
- [Match the regex below and capture its match into backreference number 4](http://www.regular-expressions.info/brackets.html) `(\S+)` 
    - [Match a single character that is NOT a “whitespace character”](http://www.regular-expressions.info/shorthand.html) `\S+` 
        - [Between one and unlimited times, as many times as possible, giving back as needed (greedy)](http://www.regular-expressions.info/repeat.html) `+`

​

​

​

用RegexBuddy创建

Answer 2

似乎您可以通过删除额外的部分和被固定宽度分割来规范数据。

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

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

希望这能有所帮助！