提取指定内容到各单元格

yshcy

数据源在A列，要求按CDE首行的内容，从A列各单元格提取内容到CDE对应的各单元格里。没有内容则填写为0

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, k&
   
    ar = [A1].CurrentRegion.Value
    [C1].CurrentRegion.Offset(1).Clear
    br = [C1].CurrentRegion.Resize(UBound(ar))
   
    For i = 2 To UBound(ar)
        cr = Split(ar(i, 1), "，")
        For j = 1 To UBound(br, 2)
            br(i, j) = 0
            For k = 0 To UBound(cr)
                If InStr(cr(k), br(1, j)) Then
                    br(i, j) = Replace(cr(k), br(1, j), "")
                    Exit For
                End If
            Next k
        Next j
    Next i
   
    [C1].Resize(UBound(br), UBound(br, 2)) = br
    Beep
End Sub

gwjkkkkk

,,,,,,,,,,,,,,,,,,,,,,,

cnmlgb9998

一个公式就能搞定的东西，要什么VBA ？？？？



365 体验版！

yshcy

cnmlgb9998 发表于 2024-7-19 19:21
一个公式就能搞定的东西，要什么VBA ？？？？

谢谢你。想学下VBA，公式太难了。

cnmlgb9998

yshcy 发表于 2024-7-19 19:31
谢谢你。想学下VBA，公式太难了。

如果你只是一般的应用，建议你 学 公式函数，如果真对公式不感冒，建议你学 PQ。PQ 解决这种问题 比公式好理解，代码比VBA 简单。

VBA 比公式和 PQ 都难！     且，VBA 很容易在学习中出现瓶颈，难以突破。


一般应用人群，不建议学VBA。因为，你学了没什么用处。能用VBA解决的，公式 或 PQ 都能达成。

醉眼看尘世

也可以这样：
Sub TEST1()
    Dim ar, br, cr, i&, j&, k&, reGxp As Object
    ar = [A1].CurrentRegion
    br = [C1].Resize(UBound(ar, 1), 3)
    Set reGxp = CreateObject("vbScript.regExp")
    reGxp.Global = False
    With reGxp
        For j = 1 To UBound(br, 2)
            .Pattern = br(1, j) & "(\d+)"
            For i = 2 To UBound(ar, 1)
                If .test(ar(i, 1)) Then br(i, j) = .Execute(ar(i, 1))(0).submatches(0) Else br(i, j) = 0
            Next i
        Next j
    End With
    [g1].Resize(UBound(br, 1), UBound(br, 2)) = br
End Sub

小凡、、、

vb同理，可以用正则

ykcbf1100

参与一下，正则提取数字

quqiyuan

参与一下。。。供参考。。。