分类提取数值

cql465505

book1.zip (10.56 KB, 下载次数: 5)

2017-12-18 10:57 上传

点击文件名下载附件

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim reg As New RegExp
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With reg
   
8.     .Global = True
   
9.     .Pattern = "([\u4e00-\u9fbb]+)[\s\.]+([\d\.]+)"
   
10.   End With
    
11.   n = 0
    
12.   With Worksheets("sheet1")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a1:a" & r)
    
15.     ReDim brr(1 To UBound(arr), 1 To 50)
    
16.     For i = 1 To UBound(arr)
    
17.       Set mh = reg.Execute(arr(i, 1))
    
18.       For j = 0 To mh.Count - 1
    
19.         mc = mh(j).SubMatches(0)
    
20.         sl = mh(j).SubMatches(1)
    
21.         If Not d.exists(mc) Then
    
22.           n = n + 1
    
23.           d(mc) = n
    
24.         End If
    
25.         brr(i, d(mc)) = Val(sl)
    
26.       Next
    
27.     Next
    
28.   End With
    
29.   With Worksheets("sheet2")
    
30.     .Cells.Clear
    
31.     .Range("a1").Resize(1, d.Count) = d.keys
    
32.     .Range("a2").Resize(UBound(brr), n) = brr
    
33.   End With
    
34. End Sub
    

复制代码

chxw68

详见附件。

LMY123

正则提取数字

cql465505

非常感谢chxw68老师的帮助（非常仔细提供2种版本文件） 麻烦看看程序不显示结果

chxw68

cql465505 发表于 2017-12-18 13:48
非常感谢chxw68老师的帮助（非常仔细提供2种版本文件） 麻烦看看程序不显示结果

结果在Sheet2表格中。

cql465505

chxw68 发表于 2017-12-18 14:27
结果在Sheet2表格中。

谢谢 非常感谢

cql465505

chxw68 发表于 2017-12-18 14:27
结果在Sheet2表格中。

麻烦可以在同一个工作表内吗 并且不要有汉字的 那一行 谢谢

chxw68

详见附件。

cql465505

非常感谢 非常感谢