下面的代码将数据从 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
我会使用正则表达式来获取值。我还将创建一个 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
^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?
选项：区分大小写；^$ 匹配换行符
^(.{6})
.{6}
{6}\s*
(.{5})
.{5}
{5}\s*
(.{4})
.{4}
{4}(?:.*1/(\S+))?
使用RegexBuddy创建
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句