[已解决]怎样在单元格中提取连续的数值

统计会计 · 发表于 2015-9-19 10:58

本帖最后由统计会计于 2015-9-19 11:23 编辑

请问在B列的单元格里怎样用代码提取出连续的数值
如：1234 1020304 12345
4个连续以上的数值

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-21 10:13

Sub 提取()
Dim crr()
arr = Range("b2:c" & [b65536].End(3).Row)
For i = 1 To UBound(arr)
x = arr(i, 1) '源数
ReDim crr(0 To 9) '定义0-9的数组
For k = 1 To Len(x) '源数各位进数组对应位置，数值大小为源数各位大小
s = Val(Mid(x, k, 1))
crr(s) = s
Next
xstr = "" '定义空字符串，用于记录连续数
For k = 1 To 9 '数组连续取数
y = crr(k)
If y > 0 Then '如果位置上有数，进字符串
xstr = xstr & y
Else '如果位置上没数
If Len(xstr) >= 4 Then arr(i, 2) = arr(i, 2) & "," & xstr '判断字符串是否大于4位，是则取用
xstr = "" '清空字符串以待下一个连续数
End If
Next
If Len(xstr) >= 4 Then arr(i, 2) = arr(i, 2) & "," & xstr '如果到最后一位，字符串未清空，判断字符串是否大于4位，是则取用
If Len(arr(i, 2)) > 0 Then arr(i, 2) = Mid(arr(i, 2), 2)
Next
Range("b2:c" & [b65536].End(3).Row) = arr
End Sub

复制代码

跳转到最佳答案楼层

Excel学徒123 · 发表于 2015-9-19 11:16

来个附件

grf1973 · 发表于 2015-9-21 10:13

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

Sub 提取()
Dim crr()
arr = Range("b2:c" & [b65536].End(3).Row)
For i = 1 To UBound(arr)
x = arr(i, 1) '源数
ReDim crr(0 To 9) '定义0-9的数组
For k = 1 To Len(x) '源数各位进数组对应位置，数值大小为源数各位大小
s = Val(Mid(x, k, 1))
crr(s) = s
Next
xstr = "" '定义空字符串，用于记录连续数
For k = 1 To 9 '数组连续取数
y = crr(k)
If y > 0 Then '如果位置上有数，进字符串
xstr = xstr & y
Else '如果位置上没数
If Len(xstr) >= 4 Then arr(i, 2) = arr(i, 2) & "," & xstr '判断字符串是否大于4位，是则取用
xstr = "" '清空字符串以待下一个连续数
End If
Next
If Len(xstr) >= 4 Then arr(i, 2) = arr(i, 2) & "," & xstr '如果到最后一位，字符串未清空，判断字符串是否大于4位，是则取用
If Len(arr(i, 2)) > 0 Then arr(i, 2) = Mid(arr(i, 2), 2)
Next
Range("b2:c" & [b65536].End(3).Row) = arr
End Sub

复制代码

grf1973 · 发表于 2015-9-21 10:14

按你模拟结果，“0”未计入连续数。

统计会计 · 发表于 2015-9-21 16:36

grf1973 发表于 2015-9-21 10:13

老师感谢您写的太详细了
解决了我工作中的问题
还有疑问请问您
如果B列的单元格里的数值是1到20呢
是不是这样改
ReDim crr(1 To 20) '定义0-9的数组
ReDim crr(1 To 20) '定义0-9的数组
我要把提取的数值分别开在各C列到D E F G H I 列里是不是这样的
arr = Range("b2:c：d:e：F:g:h:i" & [b65536].End(3).Row)

grf1973 · 发表于 2015-9-21 16:38

要是两位数的话，比较麻烦的，最好上附件。比如0121314，是认为0，1，2，3，4 呢，还是认为0，12，13，14？这不是定义数组大小的问题。当然数组大小必须是重新定义的。

grf1973 · 发表于 2015-9-21 16:41

至于要把提取的数值分别开在各C列到D E F G H I 列里这是细节，重新定义arr没有必要，需要列个显示数组。

grf1973 · 发表于 2015-9-21 16:42

理解错了。不用重新定义crr。因为crr就是存放的各位数是否出现。

统计会计 · 发表于 2015-9-21 16:58

grf1973 发表于 2015-9-21 16:42
理解错了。不用重新定义crr。因为crr就是存放的各位数是否出现。

还得老师帮忙
给个数分开到各自列里
还有就是1到20 个数值
谢谢

grf1973 · 发表于 2015-9-22 09:44

Sub 提取()
Dim crr()
arr = Range("b2:b" & [b65536].End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 10)
For i = 1 To UBound(arr)
x = arr(i, 1) '源数
ReDim crr(0 To 9) '定义0-9的数组
For k = 1 To Len(x) '源数各位进数组对应位置，数值大小为源数各位大小
s = Val(Mid(x, k, 1))
crr(s) = s
Next
xstr = "" '定义空字符串，用于记录连续数
For k = 1 To 9 '数组连续取数
y = crr(k)
If y > 0 Then '如果位置上有数，进字符串
xstr = xstr & y
Else '如果位置上没数
If Len(xstr) >= 4 Then c = c + 1: brr(i, c) = xstr '判断字符串是否大于4位，是则取用
xstr = "" '清空字符串以待下一个连续数
End If
Next
If Len(xstr) >= 4 Then c = c + 1: brr(i, c) = xstr '如果到最后一位，字符串未清空，判断字符串是否大于4位，是则取用
maxc = IIf(maxc < c, c, maxc): c = 0
Next
[c2].Resize(UBound(brr), maxc) = brr
End Sub

复制代码

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

[已解决]怎样在单元格中提取连续的数值

评分