将单元格内文字提取作为表头并对应金额

zzq0117

cnmlgb9998 发表于 2024-3-12 15:18
用PQ 不香？？？？？？？？？？？？？？？？？？？？

谢谢老师，刚试着用了一下，还真香，就是不大会用。

zzq0117

这个年纪118 发表于 2024-3-12 15:33
新手练习！！！！！！！！！！

谢谢老师，就是显示的位置有点偏离。

saghj

交个作业。。。

外块300

Sub 提取文字()
Dim ar(1 To 30, 1 To 9)
Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
rn = 1

   With CreateObject("vbscript.regexp")
        For j = 2 To UBound(arr)
                .Global = True
                .IgnoreCase = True
                .Pattern = "([一-龥]+)" '提取中文
            For Each Item In .Execute(arr(j, 17))
                  x = Item
                  If d(x) <> "" Then
                    xx = d(x)
                    ls = ls & "," & xx
                    Else
                  m = m + 1
                  d(x) = m
                ar(1, m) = Item
                    ls = ls & "," & d(x)
                    End If
            Next
            s = Split(ls, ",") '数组位置
        .Pattern = "([0-9]+\.?[0-9]{0,2})" '提取数字
        rn = rn + 1
            For Each Item In .Execute(arr(j, 17))
             n = n + 1
             ar(rn, s(n)) = Item
            Next
            n = 0
            ls = ""
        Next j
    End With
   
    Range("r1:z" & UBound(arr)) = ar
End Sub