对应项目支出的正则

yshcy

要求对数据源的日期不要分秒，同时对应支出项目金额

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, strTxt$
   
    ar = Sheets(1).[A1].CurrentRegion.Value
    With [A1].CurrentRegion
        .Offset(1).Clear
        br = .Resize(UBound(ar))
    End With
    With CreateObject("VBScript.RegExp")
        For i = 2 To UBound(ar)
            br(i, 1) = ar(i, 1)
            For j = 2 To UBound(br, 2)
                strTxt = IIf(br(1, j) = "现金", "门诊预缴金", br(1, j))
                .Pattern = strTxt & ".+?" & "([0-9\.]+)"
                If .test(ar(i, 2)) Then br(i, j) = .Execute(ar(i, 2))(0).submatches(0)
            Next j
        Next i
    End With
   
    [A1].Resize(UBound(br), UBound(br, 2)) = br
    Beep
End Sub

gwjkkkkk

请参考。。。

limonet

只能XY循环。

limonet

新公式嵌套右拉下拉：=IFNA(VLOOKUP("*"&B$1&"*",LET(fx,DROP(TEXTSPLIT(TRIM(数据源!$B2),,{";","；"}),-1),HSTACK(VSTACK(TEXTSPLIT(fx,":")),MID(fx,FIND(":",fx)+1,9))),2,),"")

yshcy

gwjkkkkk 发表于 2024-4-13 19:16
Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, strTxt$

.Offset(1).Clear有什么用处？谢谢.代码能加上注释就更好了。

ykcbf1100

数据这么规整，可以不用正则，用字典+数组也可以解决。
附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.13
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheets("数据源").UsedRange
   
4.     ReDim brr(1 To UBound(arr), 1 To 50)
   
5.     m = 1: n = 1
   
6.     brr(m, n) = arr(1, 1)
   
7.     For i = 2 To UBound(arr)
   
8.         m = m + 1
   
9.         brr(m, 1) = FormatDateTime(arr(i, 1), 2)
   
10.         st = Split(arr(i, 2), ";")
    
11.         For x = 0 To UBound(st) - 1
    
12.             b = Split(st(x), ":")
    
13.             s = Trim(b(0))
    
14.             If Not d.exists(s) Then
    
15.                 n = n + 1
    
16.                 d(s) = n
    
17.                 brr(1, n) = s
    
18.                 brr(m, n) = Val(b(1))
    
19.             Else
    
20.                 c = d(Trim(b(0)))
    
21.                 brr(m, c) = Val(b(1))
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     With Sheets("想要的结果")
    
26.         .Cells = ""
    
27.         With .[a1].Resize(m, n)
    
28.             .Value = brr
    
29.             .Borders.LineStyle = 1
    
30.             .HorizontalAlignment = xlCenter
    
31.             .VerticalAlignment = xlCenter
    
32.         End With
    
33.     End With
    
34.     Set d = Nothing
    
35.     MsgBox "OK！"
    
36. End Sub
    
37. 
    

复制代码

sdytsxd991122

参与一下

yshcy

limonet 发表于 2024-4-13 19:49
新公式嵌套右拉下拉：=IFNA(VLOOKUP("*"&B$1&"*",LET(fx,DROP(TEXTSPLIT(TRIM(数据源!$B2),,{";","；"}),-1 ...

谢谢你，函数高手。不过我想用正则解决。