请教提取的问题

ntyyz

函数公式板块里人说用VBA来解决更好，公式不好做，烦请高手帮忙看看

tudarong

感觉可以使用正则表达式来做，但我对正则还很懵懂，路过的大神请指点下。

活在理想的世界

1. Sub d()
   
2. Dim arr(), R, R1, m, w
   
3. Set w = WorksheetFunction
   
4. Set R = CreateObject("Vbscript.Regexp")
   
5. Set R1 = CreateObject("Vbscript.Regexp")
   
6. R.Global = 1: R.Pattern = "[  ,，。]+"
   
7. R1.Global = 1: R1.Pattern = "\.[一-龥]"
   
8. arr = Sheet1.Range("a1").CurrentRegion.Resize(, 2)
   
9. For i = 1 To UBound(arr)
   
10.     arr(i, 2) = R.Replace(arr(i, 1), "")
    
11.     Set m = R1.Execute(arr(i, 2))
    
12.     If m.Count > 0 Then
    
13.         For j = 1 To m.Count
    
14.             arr(i, 2) = w.Substitute(arr(i, 2), m.Item(j - 1), "." & 0 & Split(m.Item(j - 1), ".")(1))
    
15.         Next
    
16.     End If
    
17. Next
    
18. Sheet1.Range("a1").CurrentRegion.Resize(, 2) = arr
    
19. End Sub

复制代码

duquancai

。。。。。。。。。。。。。。

獨一無2

Sub 提取()
Dim result, regx, iLoop, re
    Sheet1.Cells(1, "C").Value = ""
    Set regx = CreateObject("vbscript.regexp")
    With regx
        .Global = True
        .Pattern = "([一-龢]+\d+\D?\d?)"
    Set result = .Execute(Sheet1.Cells(1, "A").Value)
   
    For iLoop = 0 To result.Count - 1
        If "." = Right(result(iLoop).submatches(0), 1) Then
            Sheet1.Cells(1, "C").Value = Sheet1.Cells(1, "C").Value + result(iLoop).submatches(0) + "0"
        Else
            Sheet1.Cells(1, "C").Value = Sheet1.Cells(1, "C").Value + result(iLoop).submatches(0)
        End If
    Next iLoop
   End With
End Sub

hopeson2010

1. Sub ek_sky()
   
2.    Dim arr As Variant, brr As Variant
   
3.    Dim dic As Object, a As Object
   
4.    Dim i As Integer, j As Integer
   
5.       Set dic = CreateObject("vbscript.regexp")
   
6.       With dic
   
7.          .Global = True
   
8.          .Pattern = "[\u4E00-\u9FA5]+\d+\.?\d?"
   
9.       arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
   
10.       ReDim brr(1 To UBound(arr), 1 To 1)
    
11.       For i = 1 To UBound(arr)
    
12.            Set a = .Execute(arr(i, 1))
    
13.            If a.Count > 0 Then
    
14.                For j = 0 To a.Count - 1
    
15.                    If a.Item(j) Like "*." Then
    
16.                       brr(i, 1) = brr(i, 1) + a.Item(j) & "0"
    
17.                    Else
    
18.                       brr(i, 1) = brr(i, 1) + a.Item(j)
    
19.                    End If
    
20.                Next j
    
21.            End If
    
22.       Next i
    
23.       End With
    
24. Range("B1").Resize(UBound(arr)) = brr
    
25. End Sub

复制代码

ntyyz

谢谢各位，等会回家到电脑上试试好不好用，先谢谢大家了。

duquancai

ntyyz 发表于 2018-7-15 10:22
谢谢各位，等会回家到电脑上试试好不好用，先谢谢大家了。

1. Sub main()
   
2.     Dim a(), js As Object
   
3.     a = Sheet1.Range("a1").CurrentRegion
   
4.     Set js = CreateObject("MSScriptControl.ScriptControl")
   
5.     js.Language = "JavaScript"
   
6.     For i = 1 To UBound(a)
   
7.         a(i, 1) = js.eval("b=[];r=/([一-﨩]+\d+\.)(\d+)?/g;while(m=r.exec('" & a(i, 1) & "'.replace(/[\s,，。]+/g,''))){(m[2])?(b.push(m[0])):(b.push(m[1]+'0'))};b.join(',');")
   
8.     Next
   
9.     Sheet1.Range("f1").Resize(UBound(a)) = a
   
10. End Sub

复制代码

ntyyz

hopeson2010 发表于 2018-7-15 10:12

谢谢，代码很好用，有个问题再请教下，以A1为列，每次更改其中的部份数据，或者粘贴用新的数据后，需要执行宏才能得到所需结果，可否我更改原始数据后，宏自动跟进进行更改。

ntyyz

活在理想的世界 发表于 2018-7-15 09:05

谢谢，代码很好用，有个问题再请教下，以A1为列，每次更改其中的部份数据，或者粘贴用新的数据后，需要执行宏才能得到所需结果，可否我更改原始数据后，宏自动跟进进行更改。