求公式或涵数来实现数值提取！

秋枫

mmlzh 发表于 2017-12-7 14:59
水平不错，去参加一下
http://club.excelhome.net/thread-1379697-1-1.html

这个对我来说难度太高：D

mmlzh

秋枫 发表于 2017-12-7 15:04
这个对我来说难度太高：D

没你想象的难，不试过咋知道呢

zhurq9876

秋枫 发表于 2017-12-7 14:54
注意：需要启用宏。

搞定，谢谢，统计有数值空格数量通过=COUNTIF(N2:N41,">0")搞定了！

hcm19522

B2:L9=IF(ISERR(-(MID(0&$A2,FIND(B$1,0&$A2)-1,1)&0))+ISERR(-MID($A2,FIND(B$1,$A2)+LEN(B$1),1)),"",-LOOKUP(9,-MID(SUBSTITUTE($A2,B$1,REPT(" ",99)),99,ROW($1:$99))))

zhurq9876

hcm19522 发表于 2017-12-7 16:24
B2:L9=IF(ISERR(-(MID(0&$A2,FIND(B$1,0&$A2)-1,1)&0))+ISERR(-MID($A2,FIND(B$1,$A2)+LEN(B$1),1)),"",-LO ...

好像不可以，如果架在附架前面，不能提取。

zhurq9876

秋枫 发表于 2017-12-7 14:54
注意：需要启用宏。

帮忙看一下是不是哪里出问题了，添加以后打开变的很慢。

秋枫

zhurq9876 发表于 2017-12-7 17:58
帮忙看一下是不是哪里出问题了，添加以后打开变的很慢。

工作量、材料表（优化函数）.7z (1.44 MB, 下载次数: 2)

2017-12-8 12:28 上传

点击文件名下载附件

优化一下，避免重复计算

1. 
   
2. Dim RegEx, Dic As Object
   
3. Dim DataStrSave As String '缓存字串，如果一样就不重复分析
   
4. 
   
5. 
   
6. Sub Auto_Open()
   
7.     Set RegEx = CreateObject("VBScript.RegExp")
   
8.     Set Dic = CreateObject("scripting.dictionary")
   
9.     RegEx.Pattern = "([^\d\.\+\s]+)([\d\.]+)"
   
10.     RegEx.IgnoreCase = True
    
11.     RegEx.Global = True
    
12. End Sub
    
13. 
    
14. Function GetNumber(data As String, key As String)
    
15.     If Trim(data) = "" Or Trim(key) = "" Then
    
16.         GetNumber = ""
    
17.         Exit Function
    
18.     End If
    
19.     If Trim(data) <> DataStrSave Then
    
20.         Dim Match, Matches As Object
    
21.         Set Matches = RegEx.Execute(data)
    
22.         Dic.RemoveAll
    
23.         For Each Match In Matches
    
24.           Dic(CStr(Match.submatches(0))) = CDbl(Match.submatches(1))
    
25.         Next
    
26.         DataStrSave = Trim(data)
    
27.     End If
    
28.     GetNumber = Dic(Trim(key))
    
29. End Function
    

复制代码

秋枫

再改进一下，直接用数组公式自定义函数。一次计算，全部填充：
工作簿1.7z (17.31 KB, 下载次数: 1)

2017-12-8 13:11 上传

点击文件名下载附件

1. Function GetNumberArray(data As Range, key As Range)
   
2.     Dim RegEx, Dic As Object
   
3.     Set RegEx = CreateObject("VBScript.RegExp")
   
4.     Set Dic = CreateObject("scripting.dictionary")
   
5.     RegEx.Pattern = "([^\d\.\+\s]+)([\d\.]+)"
   
6.     RegEx.IgnoreCase = True
   
7.     RegEx.Global = True
   
8.     Dim w, h As Long
   
9.     w = key.Columns.Count
   
10.     h = data.Rows.Count
    
11.     Dim Result(), i, j, datastr, keystr
    
12.     Dim Match, Matches As Object
    
13.     ReDim Result(1 To h, 1 To w)
    
14.     For i = 1 To h
    
15.         datastr = Trim(data.Cells(i, 1))
    
16.         If datastr <> "" Then
    
17.             Set Matches = RegEx.Execute(datastr)
    
18.             Dic.RemoveAll
    
19.             For Each Match In Matches
    
20.               Dic(CStr(Match.submatches(0))) = CDbl(Match.submatches(1))
    
21.             Next
    
22.         End If
    
23.         For j = 1 To w
    
24.             keystr = Trim(key.Cells(1, j))
    
25.             If datastr <> "" Or keystr <> "" Then
    
26.                 Result(i, j) = Dic(keystr)
    
27.             Else
    
28.                 Result(i, j) = ""
    
29.             End If
    
30.         Next j
    
31.     Next i
    
32.     GetNumberArray = Result
    
33. End Function
    

复制代码

秋枫

更正一下：前贴代码有点错误，请自己改一下：

1. Function GetNumberArray(data As Range, key As Range)
   
2.     Dim RegEx, Dic As Object
   
3.     Set RegEx = CreateObject("VBScript.RegExp")
   
4.     Set Dic = CreateObject("scripting.dictionary")
   
5.     RegEx.Pattern = "([^\d\.\+\s]+)([\d\.]+)"
   
6.     RegEx.IgnoreCase = True
   
7.     RegEx.Global = True
   
8.     Dim w, h As Long
   
9.     w = key.Columns.Count
   
10.     h = data.Rows.Count
    
11.     Dim Result(), i, j, datastr, keystr
    
12.     Dim Match, Matches As Object
    
13.     ReDim Result(1 To h, 1 To w)
    
14.     For i = 1 To h
    
15.         datastr = Trim(data.Cells(i, 1))
    
16.         If datastr <> "" Then
    
17.             Set Matches = RegEx.Execute(datastr)
    
18.             Dic.RemoveAll
    
19.             For Each Match In Matches
    
20.               Dic(CStr(Match.submatches(0))) = CDbl(Match.submatches(1))
    
21.             Next
    
22.         End If
    
23.         For j = 1 To w
    
24.             keystr = Trim(key.Cells(1, j))
    
25.             If datastr <> "" And keystr <> "" Then
    
26.                 Result(i, j) = Dic(keystr)
    
27.             Else
    
28.                 Result(i, j) = ""
    
29.             End If
    
30.         Next j
    
31.     Next i
    
32.     GetNumberArray = Result
    
33. End Function

复制代码