很复杂的提取数据

msboxing · 发表于 2019-3-20 08:45

请教，怎么把一串文字中的数据，按数字分割出来，详见附件。

新建 Microsoft Excel 工作表.rar (6.54 KB, 下载次数: 26)

duquancai · 发表于 2019-3-20 08:58

手机上网，下载不了附件

ming0018 · 发表于 2019-3-20 09:01

用正则试一下

yuygog · 发表于 2019-3-20 10:14

Sub 提取数据()

On Error Resume Next

Dim matches, match, qz$, str$, pps%, arr()

For Each cell In Selection

      str = cell.Value

      With CreateObject("VBSCRIPT.REGEXP")

      .Pattern = ".*?(购买|采购)"

      .Global = True

      If .test(cell.Value) Then
      qz = .Execute(cell.Value)(0)
      str = Replace(str, qz, "")

      End If

      End With



      With CreateObject("VBSCRIPT.REGEXP")

      .Pattern = "[\u2E80-\u9FFF].*?(元|\d |$)"

      .Global = True

      If .test(str) Then

      Set matches = .Execute(str)

      For Each match In matches

      pps = pps + 1

      ReDim Preserve arr(1 To pps)

      arr(pps) = qz & Trim(match.Value)

      Next match

      End If

      End With


      qz = ""
      str = ""


      Set matches = Nothing
      Set match = Nothing

Next cell

'Range([B3], Cells(Rows.Count, "B").End(xlUp)).ClearContents

[B3].Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr) '处理后的数据放入第二列

End Sub

wzsy2_mrf · 发表于 2019-3-20 11:00

本帖最后由 wzsy2_mrf 于 2019-3-20 11:08 编辑

Sub aa()
Dim arr, i&, j&, k&, reg, brr(1 To 10000), trr
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "(([1-9]\d*\.?\d*)|(0\.\d*[1-9])|(采购)|(购买))" '必须外加括号
reg.Global = True
k = 1
arr = Range("d2").CurrentRegion
For i = 2 To UBound(arr)
arr(i, 1) = reg.Replace(arr(i, 1), "$1元")
trr = Split(arr(i, 1), "元")
For j = 1 To UBound(trr)
If trr(j) <> "" Then
brr(k) = trr(0) & trr(j) & "元"
k = k + 1
End If
Next
Next
Range("h3").Resize(k) = Application.WorksheetFunction.Transpose(brr)
End Sub

复制代码

msboxing · 发表于 2019-3-20 14:19

wzsy2_mrf 发表于 2019-3-20 11:00

效果非常好，谢谢！

msboxing · 发表于 2019-3-20 14:28

yuygog 发表于 2019-3-20 10:14
Sub 提取数据()

On Error Resume Next

谢谢，大师的风采。

msboxing · 发表于 2019-3-25 21:23

wzsy2_mrf 发表于 2019-3-20 11:00

大师，我把数据调整了一下，就不好用了，请教怎么修改呢？

新建 Microsoft Excel 工作表2.rar (14.83 KB, 下载次数: 2)

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

[求助] 很复杂的提取数据

评分

评分

评分

最新热点 /1