[已解决]在原值提取数字

love586

在原值提取数字
学了一点，嵌套不了，求高手援手一下

1. Sub test_1()
   
2. Dim arr1, arr2, arrRst$(), i&, j&, k&, b As Boolean, sTmp$
   
3. t = Timer
   
4. arr1 = Range("a2:a103")
   
5. arr2 = [b1].Resize(, Cells(1, Columns.Count).End(1).Column - 1)
   
6. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
7. For i = 1 To UBound(arr1)
   
8.   For j = 1 To UBound(arr2, 2)
   
9.     b = False
   
10.     For k = 2 To Len(arr1(i, 1)) - 1
    
11.       sTmp = Mid(arr1(i, 1), k, 1)
    
12.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), sTmp) Then b = True: Exit For 'instr比like效率高
    
13.       'If Not IsNumeric(sTmp) Then If arr2(1, j) Like "*" & sTmp & "*" Then b = True: Exit For
    
14.     Next
    
15.     If b = False Then arrRst(i, j) = arr1(i, 1) & arr2(1, j)
    
16.   Next j
    
17. Next i

复制代码

提取数字.rar (138.29 KB, 下载次数: 18)

2021-12-22 15:44 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2021-12-22 19:21

这样

1. Sub test_1()
   
2. Dim arr1, arr2, arrRst(), i&, j&, k&, b As Boolean, sTmp$, reg As Object
   
3. t = Timer
   
4. Set reg = CreateObject("vbscript.regexp")
   
5. reg.Global = True
   
6. reg.Pattern = "[A-Z()]"
   
7. arr1 = Range("a2:a103")
   
8. arr2 = [b1].Resize(, Cells(1, Columns.Count).End(1).Column - 1)
   
9. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
10. For i = 1 To UBound(arr1)
    
11.   For j = 1 To UBound(arr2, 2)
    
12.     b = False
    
13.     For k = 2 To Len(arr1(i, 1)) - 1
    
14.       sTmp = Mid(arr1(i, 1), k, 1)
    
15.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), sTmp) Then b = True: Exit For
    
16.     Next
    
17.     If b = False Then arrRst(i, j) = reg.Replace(arr1(i, 1) & arr2(1, j), "")
    
18.   Next j
    
19. Next i
    
20. [b2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
    
21. MsgBox Timer - t
    
22. End Sub

复制代码

跳转到最佳答案楼层

love586

vitrel 发表于 2021-12-22 16:01
楼主，您好！
您想要怎样的结果？如果您不交待清楚的话，很难下手的。

1. Sub test_5()
   
2. Dim arr1, arr2, arrRst$(), i&, j&, k&, b As Boolean, sTmp$
   
3. t = Timer
   
4. arr1 = Range("a2:a503")
   
5. arr2 = [b1].Resize(, Cells(1, Columns.Count).End(1).Column - 1)
   
6. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
7. For i = 1 To UBound(arr1)
   
8.   For j = 1 To UBound(arr2, 2)
   
9.     b = False
   
10.     For k = 2 To Len(arr1(i, 1)) - 1
    
11.       sTmp = Mid(arr1(i, 1), k, 1)
    
12.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), sTmp) Then b = True: Exit For 'instr比like效率高
    
13.       'If Not IsNumeric(sTmp) Then If arr2(1, j) Like "*" & sTmp & "*" Then b = True: Exit For
    
14.     Next
    
15.     If b = False Then arrRst(i, j) = arr1(i, 1) & arr2(1, j)
    
16.   Next j
    
17. Next i
    
18. [b2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
    
19. MsgBox Timer - t
    
20. End Sub
    
21. 
    

复制代码

在这代码那里替换，红色去掉字母和括号，提取数字
If b = False Then arrRst(i, j) = Replace(arr1(i, 1) ,“a-z,()”）& Replace(arr2(1, j)，“a-z（）”）

vitrel

楼主，您好！
您想要怎样的结果？如果您不交待清楚的话，很难下手的。

大灰狼1976

replace函数不支持通配符，可以用正则解决

vitrel

love586 发表于 2021-12-22 16:15
在这代码那里替换，红色去掉字母和括号，提取数字
If b = False Then arrRst(i, j) = Replace(arr1(i, 1 ...

单纯要实现“去掉字母和括号，提取数字”，最快的方法是正则，您那个是一个表格，既有行标题，也有列标题，
最主要是的不知道您提取数字以后怎么做（放在哪），
您做个样式出来以后，
按理几行代码就能实现，应该不需要您那些这么复杂的代码。
所以我才想问您想要的最终结果是什么。

林木水

1. <div class="blockcode"><blockquote>Function shuzi(rg As Range)
   
2.     Dim m, mat, sr
   
3.     Dim ex As Object
   
4.     Set ex = CreateObject("VBscript.regexp")
   
5.     With ex
   
6.         .Global = True
   
7.         .Pattern = "\d+"
   
8.         Set mat = .Execute(rg.Value)
   
9.         For Each m In mat
   
10.             sr = sr & m
    
11.         Next m
    
12.     End With
    
13.     shuzi = sr
    
14. End Function
    

复制代码

思路：1.做一个自定义函数
2.用正则表达式做
3.最重要的，解决问题给最佳
你的需求不够明确，是在原来的基础上面提取数字，把值覆盖原来的值，还是把提取的值放到某个区域？
不过这个提取数字是非常简单的，用正则表达式。麻烦把需求明确清楚，好一步到位

这样把，给你写一个自定义函数公式，提取数字，直接使用自定义函数公式就可以啦。

love586

林木水 发表于 2021-12-22 17:59
思路：1.做一个自定义函数
2.用正则表达式做
3.最重要的，解决问题给最佳

自定义我有，1亿个单元格，拉不动啊大哥，除掉空值，真值2900多万个值呢
样本图

love586

大灰狼1976 发表于 2021-12-22 17:28
replace函数不支持通配符，可以用正则解决

我换个码试试，保存有几个

love586

vitrel 发表于 2021-12-22 17:48
单纯要实现“去掉字母和括号，提取数字”，最快的方法是正则，您那个是一个表格，既有行标题，也有列标题 ...

我只是想要最后的赋值提取数字，在输出到单元格，插入其他码，输出全是0，要么全是1

大灰狼1976

这样

1. Sub test_1()
   
2. Dim arr1, arr2, arrRst(), i&, j&, k&, b As Boolean, sTmp$, reg As Object
   
3. t = Timer
   
4. Set reg = CreateObject("vbscript.regexp")
   
5. reg.Global = True
   
6. reg.Pattern = "[A-Z()]"
   
7. arr1 = Range("a2:a103")
   
8. arr2 = [b1].Resize(, Cells(1, Columns.Count).End(1).Column - 1)
   
9. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
10. For i = 1 To UBound(arr1)
    
11.   For j = 1 To UBound(arr2, 2)
    
12.     b = False
    
13.     For k = 2 To Len(arr1(i, 1)) - 1
    
14.       sTmp = Mid(arr1(i, 1), k, 1)
    
15.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), sTmp) Then b = True: Exit For
    
16.     Next
    
17.     If b = False Then arrRst(i, j) = reg.Replace(arr1(i, 1) & arr2(1, j), "")
    
18.   Next j
    
19. Next i
    
20. [b2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
    
21. MsgBox Timer - t
    
22. End Sub

复制代码