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

下面的代码将数据从1个单元格分成3个或4个单元格。 我遇到的问题是数据不属于任何一种情况，有时它会开始分裂一个案件，有时如果它低于15个字符。 然后，如果再次运行它，只发现6个字符，它将在单元格1中写入6个字符，然后如果第一次分割完成，并且第二次数据是正确的，则运行将覆盖空白单元格。 如果分割完成，就不能解决如何解决这个问题，然后忽略所选的内容，如果它不属于任何情况，则忽略单元格并移到下一个单元格。

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

我将使用正则expression式来获取值。 我也会创build一个Class对象来处理数据。 类对象的属性将是您正在查找的项目。 我们把所有的类对象集合到一个集合中; 那么输出结果是微不足道的。

编辑 ：

• 正则expression式更正为允许可选的大小参数。
• testing添加到退出macros，如果零匹配。
• testing添加检查只是一条线被拆分

我基于您的代码和示例的字段定义。 所以，如果他们不是全部包容性的，那就回到“失败”。

使用一个类让程序更加自我logging，并且使得将来的修改更容易

务必按照注释中所述重命名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 

正则expression式

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

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

选项：区分大小写; 换行符$ ^

• 断言位置在一行 ^ 的开头
• 匹配下面的正则expression式并将其匹配到反向引用编号1 (.{6})
  • 匹配任何不是换行符的单个字符 .{6}
    • 恰好6次 {6}
• 匹配一个“空白字符”的单个字符 \s*
  • 在零和无限次之间，尽可能多次，根据需要回馈（贪婪） *
• 匹配下面的正则expression式并将其匹配到反向引用编号2 (.{5})
  • 匹配任何不是换行符的单个字符 .{5}
    • 正好5次 {5}
• 匹配一个“空白字符”的单个字符 \s*
  • 在零和无限次之间，尽可能多次，根据需要回馈（贪婪） *
• 匹配下面的正则expression式并将其匹配到反向引用编号3 (.{4})
  • 匹配任何不是换行符的单个字符 .{4}
    • 正好4次 {4}
• 匹配下面的正则expression式 (?:.*1/(\S+))?
  • 在零次和一次之间，尽可能多次，根据需要回馈（贪婪） ?
  • 匹配任何不是换行符的单个字符 .*
    • 在零和无限次之间，尽可能多次，根据需要回馈（贪婪） *
  • 匹配string“1 /”字面上 1/
  • 匹配下面的正则expression式并将其匹配到反向引用编号4 (\S+)
    • 匹配不是“空白字符” \S+ 的单个字符
      • 在一次和无限次之间，尽可能多的次数，根据需要回馈（贪婪） +

用RegexBuddy创build

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等从以前的迭代将被使用。

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

另一个select是添加类似errFlag = 1到Case Else ，然后对dst的负载进行testing：

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

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

希望这可以帮助！

Answer 4

^{我在等待评论的回答时写了这个。 罗恩·罗森菲尔德最近基于正则expression式的答案比这个更彻底，但是我发布了它，以防你想要创build一个函数而不是子程序的方向。 这里使用的正则expression式。模式是基于你的原始样本数据，不会在你的新样本数据上工作（我不打算在任何情况下重新input）}

使用基于正则expression式文本parsing的用户定义函数来分离第一组小写字母。 之后，任何被定位为另一个占位符的东西只能是一个字符。

 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 = "[az]{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