单元格中的数字分别提取出来

hpf1984 · 发表于 2017-4-21 10:53

可不可以把一个单元格中的数字分别提取出来，
比如：A1单元格支3920终00000001好50915274 有三个数字分别可以在B1单元格提取3920 C1单元格提取00000001 D1单元格提取50915274
如果还有第四个数字，那就放在E1 以此类推；
详见附件表格，因为单元格比较乱，感觉上没有统一的逻辑，尽量可以把大部分的匹配出来，公式好像做不了了，麻烦高手帮忙写个宏。
谢谢高手们！

小花鹿 · 发表于 2017-4-21 11:13

这种问题用正则最合适了，当然，用循环把数字替换为空格也可以...............................................

梁三刀木 · 发表于 2017-4-21 11:31

小花鹿发表于 2017-4-21 11:13
这种问题用正则最合适了，当然，用循环把数字替换为空格也可以.......................................... ...

Sub aa()

Dim rz As Object
Dim 数据源 As String, Item As Double '声明变量
For a = 2 To Cells(Rows.Count, 1).End(3).Row
数据源 = Range("a" & a)
With CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
  .Global = True    '全局匹配
  .Pattern = "[0-9]{4,}"  '指定匹配条件
  Set Matches = .Execute(数据源)  '执行匹配
  For Each Match In Matches '遍历匹配的结果
b = b + 1
Cells(a, b + 1) = Match
  Next
  b = 0
  Set Matches = Nothing
End With
Next

End Sub

试一试吧，有问题可以联系QQ158456166

microyip · 发表于 2017-4-21 11:31

这种还真使用正则最合适不过，可惜我只能看看，帮不了，不懂正则

梁三刀木 · 发表于 2017-4-21 11:32

Sub aa()

Dim rz As Object
Dim 数据源 As String, Item As Double '声明变量
For a = 2 To Cells(Rows.Count, 1).End(3).Row
数据源 = Range("a" & a)
With CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
  .Global = True    '全局匹配
  .Pattern = "[0-9]{4,}"  '指定匹配条件
  Set Matches = .Execute(数据源)  '执行匹配
  For Each Match In Matches '遍历匹配的结果
b = b + 1
   Cells(a, b + 1) = Match
Next
b = 0
Set Matches = Nothing
End With
Next

End Sub

试一试吧，有问题可以联系QQ158456166

梁三刀木 · 发表于 2017-4-21 11:58

Sub aa()
Application.ScreenUpdating = False

Dim rz As Object
Dim 数据源 As String, Item As Double '声明变量
For a = 2 To Cells(Rows.Count, 1).End(3).Row
数据源 = Range("a" & a)
With CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
  .Global = True    '全局匹配
  .Pattern = "[0-9]{1,}[^(\.|/)][0-9]\b"  '指定匹配条件
  Set Matches = .Execute(数据源)  '执行匹配
  For Each Match In Matches '遍历匹配的结果
b = b + 1
Cells(a, b + 1) = Match
  Next
  b = 0
  Set Matches = Nothing
End With
Next
Application.ScreenUpdating = True

End Sub

这个匹配更好，把一些乱结果除去了。

尼古丁vs乙醇 · 发表于 2017-4-21 12:36

非正则方法路过

Sub 数字()
Dim num, i, j, N, M, CV
For i = 2 To Cells(65536, 1).End(xlUp).Row
CV = "@" & Cells(i, 1) & "@"
M = 0
N = 2
num = ""
For j = 1 To Len(CV)
If IsNumeric(Mid(CV, j, 1)) Then
M = M + 1
num = num & Mid(CV, j, 1)
GoTo ST
ElseIf M > 3 Then
Cells(i, N) = num
N = N + 1
End If
num = ""
M = 0
ST:
Next
Next
End Sub

复制代码

小花鹿 · 发表于 2017-4-21 13:10

3.29要匹配吗？....................................................................................................

lsdongjh · 发表于 2017-4-21 13:30

本帖最后由 lsdongjh 于 2017-4-21 13:33 编辑

用正则最简单，见代码：

Sub Test()
Application.ScreenUpdating = False
Application.Cursor = xlWait
Dim lngRows As Long, lngR As Long
Dim strTemp As String
Dim strR As Variant
lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For lngR = 2 To lngRows
strTemp = Sheet1.Range("A" & lngR).Value2
strR = GetDigit(strTemp)
If IsEmpty(strR) = False Then Sheet1.Range("B" & lngR).Resize(1, UBound(strR)) = strR
Next
Application.ScreenUpdating = True
Application.Cursor = xlDefault
End Sub
Function GetDigit(strValue As String) As Variant
Dim objReg As Object
Dim objMatchs As Object, objMatch As Object
Dim strPat As String
Dim strResult() As String '字符型String可以得到[00001],如果想直接得到数字，可以定义为长整型Long
Dim intIndex As Integer
strPat = "\d+\.*\d*"
Set objReg = CreateObject("VBScript.RegExp")
With objReg
.Global = True
.Pattern = strPat
Set objMatchs = .Execute(strValue)
intIndex = objMatchs.Count
If intIndex > 0 Then
ReDim strResult(1 To objMatchs.Count)
intIndex = 0
For Each objMatch In objMatchs
intIndex = intIndex + 1
strResult(intIndex) = objMatch
Next
GetDigit = strResult
End If
End With
End Function

复制代码

hpf1984 · 发表于 2017-4-21 14:57

梁三刀木发表于 2017-4-21 11:58
Sub aa()
Application.ScreenUpdating = False

感谢，太感谢了，崇拜之情如滔滔江水
也感谢楼上的大家帮忙

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

[已解决] 单元格中的数字分别提取出来

评分

评分

评分

最新热点 /1