在Excel单元格中提取固定位数的数字有很多公式就可以解决，如right、left等。但是有这样的一组数据（图1）。在B列中有一串字符串，需要将这些数字提取出来，并实现图2中的效果，不知大家有什么好的办法。
原始数据
效果图
如果数据量仅仅是只有数十个，那么通过分列，提取出相应的数字，然后手动操作，虽然耗一些时间，但是仍然能够达到目的。但如果这些数据达到数百个甚至于数千个，如果通过手动操作可能就比较费时，同时也比较容易出错。
我对于数组公式的运用不是很熟悉，因此并不知道能否通过数组公式达到此目的，但是在Excel中运行数组公式，虽能做到数据的实时更新，但也很容易造成程序运行缓慢。在没有找到合适插件的同时，我只能用VBA来完成。
在菜单栏，找到“开发工具”点击“visual basic”，进入后选择新建一个“模块”，将代码放入其中，然后选择将文件保存为“启用宏的文件”。在需操作数据时，点击开发工具中的“宏”，并选择相应的代码名称即可。
运行此代码时要注意将需要拆分的列放在最后一列，如下面这组数据，在操作后，我需要保存A和B列的数据，并且拆分B列中的数字，那么在其起始列为“A”列，列数为2列，并且B列为所选区域的最后一列。需要提取的数字为3位数，直接在第二个弹出框选择3即可实现。
部分代码为：
Sub 拆分3列8位数字()
Dim i As Integer, rr As Integer, arr(), brr(), crr()
Dim j As Integer, n As Integer, k As Integer, cs As Integer
Set cf = CreateObject("vbscript.regexp")
With ActiveSheet
rr = .Cells(Rows.Count, 3).End(xlUp).Row
arr = Range("a1:c" & rr)
With cf
.Global = True
.Pattern = "\d{8,}-?"
For i = 1 To UBound(arr)
If i = 1 Then
Set mat = *******
If mat.Count = 0 Then
ReDim Preserve brr(1 To 4, 1 To 1)
brr(1, 1) = arr(i, 1)
brr(2, 1) = arr(i, 2)
brr(3, 1) = arr(i, 3)
brr(4, 1) = ""
ElseIf mat.Count = 1 Then
ReDim Preserve brr(1 To 4, 1 To 1)
brr(1, 1) = arr(i, 1)
brr(2, 1) = arr(i, 2)
brr(3, 1) = arr(i, 3)
brr(4, 1) = mat(0)
Else
ReDim Preserve brr(1 To 4, 1 To mat.Count)
brr(1, 1) = arr(i, 1)
brr(2, 1) = arr(i, 2)
brr(3, 1) = arr(i, 3)
For j = 0 To UBound(mat)
brr(4, 1 + j) = mat(j)
Next
End If
Else
n =*******
Set mat = *********
If mat.Count = 0 Then
ReDim Preserve brr(1 To 4, 1 To n)
brr(1, n) = arr(i, 1)
brr(2, n) = arr(i, 2)
brr(3, n) = arr(i, 3)
brr(4, n) = ""
ElseIf mat.Count = 1 Then
ReDim Preserve brr(1 To 4, 1 To n)
brr(1, n) = arr(i, 1)
brr(2, n) = arr(i, 2)
brr(3, n) = arr(i, 3)
brr(4, n) = mat(0)
Else
ReDim Preserve brr(1 To 4, 1 To mat.Count + n - 1)
brr(1, n) = arr(i, 1)
brr(2, n) = arr(i, 2)
brr(3, n) = arr(i, 3)
For j = 0 To mat.Count - 1
brr(4, n + j) = mat(j)
Next
End If
End If
Next
End With
For k = 1 To UBound(brr, 2)
If InStr(brr(4, k), "-") <> 0 Then
brr(4, k) = Replace(brr(4, k), "-", "")
cs = brr(4, k + 1) - brr(4, k) - 1
QS = UBound(brr, 2)
ReDim Preserve brr(1 To 4, 1 To QS + cs)
n = UBound(brr, 2)
For t = n To k + 2 Step -1
brr(1, t) = brr(1, t - cs)
brr(2, t) = brr(2, t - cs)
brr(3, t) = brr(3, t - cs)
brr(4, t) = brr(4, t - cs)
Next
For bc = 1 To cs
brr(1, k + bc) = brr(1, k)
brr(2, k + bc) = brr(2, k)
brr(3, k + bc) = brr(3, k)
brr(4, k + bc) = brr(4, k) * 1 + bc
Next
End If
Next
End With
End Sub
网友评论