[已解决]请老师帮忙对数据进行拆分，谢谢苏子龙老师！

lhj323323 · 发表于 2017-4-16 10:40

本帖最后由 lhj323323 于 2017-4-16 22:21 编辑

老师：

我想对指定列的数据，按固定顺序的关键词进行拆分，并导入到同一工作表的其它列里，详细需求，请看附件，先谢谢了
请用VBA来实现。

新建.rar (12.51 KB, 下载次数: 5)

苏子龙 · 发表于 2017-4-16 11:50

Sub tt()
Dim arr, arr2, i%, y%
Dim reg, mh
Sheet2.Activate
Application.ScreenUpdating = False
arr = Range("a2:d" & Range("a65536").End(xlUp).Row)
ReDim arr2(1 To UBound(arr), 1 To 6)
Set reg = CreateObject("vbscript.regexp")
For i = 1 To UBound(arr)
For y = 1 To 3
arr2(i, y) = arr(i, y)
If arr(i, 3) <> "" Then
reg.Pattern = Mid("送转派", y, 1) & "(\d+\.?\d*)"
If reg.test(arr(i, 4)) Then
Set mh = reg.Execute(arr(i, 4))
arr2(i, y + 3) = mh(0).submatches(0)
End If
End If
Next
Next
Range("f2:l65536").ClearContents
Range("g2").Resize(UBound(arr), 6) = arr2
Range("g:g").NumberFormatLocal = "000000"
Application.ScreenUpdating = True
End Sub

复制代码

雄鹰2013 · 发表于 2017-6-13 21:17

Sub 分组()
Dim regex As New RegExp
Dim arr
Dim m As IMatch2
t = Timer
arr = Range("a2:d1000")
ReDim brr(1 To UBound(arr), 1 To 6)
With regex
.Global = True
.Pattern = "(?

送|转|派))(\d+(\.\d+)?)"
   For i = 1 To UBound(arr)
      If .Test(arr(i, 4)) Then
      Set ma = .Execute(arr(i, 4))
            x = x + 1
            For j = 1 To 3
               brr(x, j) = arr(i, j)
            Next j
            For Each m In ma
               Select Case m.SubMatches(0)
                     Case "送"
                        brr(x, 4) = m.SubMatches(1)
                     Case "转"
                        brr(x, 5) = m.SubMatches(1)
                     Case "派"
                        brr(x, 6) = m.SubMatches(1)
               End Select
            Next m
      End If
   Next i
End With
Range("g2:l1000").ClearContents
Range("g2").Resize(x, 6) = brr
MsgBox Format(Timer - t, "0.000秒")
End Sub

雄鹰2013 · 发表于 2017-6-13 21:19

Sub 分组()
Dim regex As New RegExp
Dim arr
Dim m As IMatch2
t = Timer
arr = Range("a2:d1000")
ReDim brr(1 To UBound(arr), 1 To 6)
With regex
.Global = True
.Pattern = "(?

送|转|派))(\d+(\.\d+)?)"
   For i = 1 To UBound(arr)
      If .Test(arr(i, 4)) Then
      Set ma = .Execute(arr(i, 4))
            x = x + 1
            For j = 1 To 3
               brr(x, j) = arr(i, j)
            Next j
            For Each m In ma
               Select Case m.SubMatches(0)
                     Case "送"
                        brr(x, 4) = m.SubMatches(1)
                     Case "转"
                        brr(x, 5) = m.SubMatches(1)
                     Case "派"
                        brr(x, 6) = m.SubMatches(1)
               End Select
            Next m
      End If
   Next i
End With
Range("g2:l1000").ClearContents
Range("g2").Resize(x, 6) = brr
MsgBox Format(Timer - t, "0.000秒")
End Sub

雄鹰2013 · 发表于 2017-6-13 21:21

通过测试速度上好像快了点

		自动登录	找回密码
密码			注册

[已解决]请老师帮忙对数据进行拆分，谢谢苏子龙老师！

评分