如何按要求提取单元格中的数值

dtlcg

各位老师，我想从单元格中将数值提取出来后填到对应的单元格中，请问如何操作？我知道应该用正则，可不会写，麻烦各位老帮忙，谢谢！

shiruiqiang

卫生系统的帮一下

shiruiqiang

减轻一点报表负担

longwin

1. Sub test()
   
2. With Sheets(1)
   
3. l = .[A1].End(xlDown).Row
   
4. arr = .Range("a2:a" & l)
   
5. crr = .Range("B1:f1")
   
6. ReDim brr(1 To l, 1 To 5)
   
7. For i = 1 To l - 1
   
8. s = Split(arr(i, 1), " ")
   
9. For j = 0 To UBound(s)
   
10.     For t = 1 To UBound(crr, 2)
    
11.         If InStr(1, s(j), crr(1, t)) > 0 Then
    
12.             brr(i, t) = Trim(Replace(s(j), crr(1, t) & "：", ""))
    
13.         End If
    
14.     Next
    
15. Next
    
16. Next
    
17. .Range("B2:F" & l) = brr()
    
18. End With
    
19. End Sub

复制代码

longwin

ooluckydog

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&
   
    ar = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    br = [B1:F1].Resize(UBound(ar))
   
    With CreateObject("VBScript.RegExp")
        For i = 2 To UBound(ar)
            For j = 1 To UBound(br, 2)
                .Pattern = br(1, j) & "：" & "[0-9\.]+.+?\b"
                If .test(ar(i, 1)) Then
                    br(i, j) = Replace(.Execute(ar(i, 1))(0).Value, br(1, j) & "：", "")
                Else
                    br(i, j) = Empty
                End If
            Next j
        Next i
    End With
    [B1].Resize(UBound(br), UBound(br, 2)) = br
    Beep
End Sub

gwjkkkkk

请参考附件。。。

liulang0808

Sub test()
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Offset(1, 1).ClearContents
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr) - 1
        For i = 2 To UBound(arr, 2)
            If InStr(arr(j, 1), arr(1, i)) > 0 Then
                arr(j, i) = Split(Split(arr(j, 1), arr(1, i) & "：")(1), " ")(0)
            End If
        Next i
    Next j
    [a1].CurrentRegion = arr
    Application.ScreenUpdating = True
End Sub

下面这个通用性能强一些
Sub test1()
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Offset(1, 1).ClearContents
    arr = [a1].CurrentRegion
    With CreateObject("vbscript.regexp")
        .IgnoreCase = True
        For j = 2 To UBound(arr)
            For i = 2 To UBound(arr, 2)
                .Pattern = arr(1, i) & "[：:\s]*(\d+\.?\d*)(kg|cm|两|支)?"
                If .test(arr(j, 1)) Then
                    Set m = .Execute(arr(j, 1))(0)
                    arr(j, i) = m.submatches(0) & m.submatches(1)
                End If
            Next i
        Next j
    End With
    [a1].CurrentRegion = arr
    Application.ScreenUpdating = True
End Sub

cnmlgb9998

用PQ 简简单单就搞定，不香么？？？？？？？？？？？？？