|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub TEST2()
Dim ar, br, cr, i&, j&, k&, r&, m&, n&, strTemp$
Application.ScreenUpdating = False
ar = Intersect([A1].CurrentRegion, Columns("B:E")).Value
ReDim br(10 ^ 3, 1 To 3)
br(0, 1) = "物料编号": br(0, 2) = "物料名称": br(0, 3) = "零件位置"
With CreateObject("VBScript.RegExp")
.Pattern = "([A-Z]+)(\d+)\-([A-Z]+)(\d+)"
For i = 2 To UBound(ar)
ar(i, 4) = Replace(ar(i, 4), Chr(10), "")
cr = Split(ar(i, 4), ",")
For j = 0 To UBound(cr)
If .TEST(cr(j)) Then
strTemp = .Execute(cr(j))(0).submatches(0)
m = .Execute(cr(j))(0).submatches(1)
n = .Execute(cr(j))(0).submatches(3)
For k = m To n
r = r + 1
br(r, 1) = ar(i, 1): br(r, 2) = ar(i, 2): br(r, 3) = strTemp & m
Next k
Else
r = r + 1
br(r, 1) = ar(i, 1): br(r, 2) = ar(i, 2): br(r, 3) = cr(j)
End If
Next j
Next i
End With
With Worksheets(2)
.Cells.Clear
.[A1].Resize(r + 1, 3) = br
.Activate
End With
Application.ScreenUpdating = True
Beep
End Sub
|
评分
-
1
查看全部评分
-
|