分拆

ddz79101 · 发表于 2024-9-12 08:35

老师！有1表格数据，我希望单元格经分拆和移动如表有的样张。谢谢

chxw68 · 发表于 2024-9-12 09:08

Sub test()
Dim r%, i%
Dim arr, brr, crr()
Dim reg1 As New RegExp
Dim reg2 As New RegExp
Dim reg3 As New RegExp
With reg1
.Global = False
.Pattern = "^\d{18}"
End With
With reg2
.Global = False
.Pattern = "^\d{18}\s*(.+?)(\d{4}-\d{1,2}-\d{1,2}\s*至\s*\d{4}/\d{1,2}/\d{1,2})\s*(\d{4}-\d{1,2}-\d{1,2})\s*([\d\.,]+)"
End With
With reg3
.Global = False
.Pattern = "金额合计.+?([\d.]+)"
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
If Not arr(i, 1) Like "金额合计*" Then
If reg1.test(arr(i, 1)) Then
m = m + 1
End If
brr(m, 1) = brr(m, 1) & arr(i, 1)
Else
Set mh = reg3.Execute(arr(i, 1))
If mh.Count > 0 Then
hj = mh(0).SubMatches(0)
End If
End If
Next
ReDim crr(1 To m + 1, 1 To 4)
n = 0
For i = 1 To m
Set mh = reg2.Execute(brr(i, 1))
If mh.Count > 0 Then
n = n + 1
crr(n, 1) = mh(0).SubMatches(0)
crr(n, 2) = Replace(mh(0).SubMatches(1), Space(1), Empty)
crr(n, 3) = mh(0).SubMatches(2)
crr(n, 4) = mh(0).SubMatches(3)
End If
Next
n = n + 1
crr(n, 1) = "金额合计"
crr(n, 4) = hj
If n > 0 Then
.Range("d1").Resize(n, UBound(crr, 2)) = crr
End If
End With
End Sub

复制代码

chxw68 · 发表于 2024-9-12 09:10

不太好处理，抛砖引玉吧。

mjm04 · 发表于 2024-9-12 10:32

原始数据相当不友好！乱的一B啊

WPS-正则参与一下下，开个火车车

最后的汇总金额，自己SUM一下吧
EXCEL需要换成自己的正则函数，正则表达式不变

=HSTACK(TOCOL(REGEXP(A1:A15,"[一-龢、*]+(?=2024)|[一-龢]{5,}"),3),TOCOL(REGEXP(A1:A15,"20.+至"),3)&TOCOL(TEXT(IF(ISNUMBER(A1:A15),A1:A15,AA),"yyyy-m-d"),3),TOCOL(REGEXP(A1:A15,".+(?= \d+,*\d{2,}\.\d{2,})"),3),TOCOL(REGEXP(A1:A15,"\d+,*\d{2,}\.\d{2,}")*1,3))

limonet · 发表于 2024-9-12 10:44

Sub limonet()
Dim S$, i%, j%
With CreateObject("vbscript.regexp")
Do While i < 17
      Do
         i = 1 + i
         S = S & " " & Cells(i, "A").Text
      Loop Until Cells(i, "A") Like "[1-9]*.[0-9][0-9]" Or i >= 16
      j = j + 1
      If S Like " [1-9]*" Then
         .Pattern = ".*?([一-龥、]+) ?(\d+-\d+-\d+ 至 \d+-\d+-\d+) (\d+-\d+-\d+) (\d+(\.\d+)?)"
         Cells(j, "C").Resize(1, 4) = Split(.Replace(S, "$1￥$2￥$3￥$4"), "￥")
      Else
         .Pattern = "人民币[一-龥、]+"
         Cells(j, "C").Resize(1, 4) = Split(.Replace(S, "￥￥"), "￥")
      End If
      S = ""
Loop
End With
End Sub

limonet · 发表于 2024-9-12 10:46

关键字：do loop

taller · 发表于 2024-9-12 11:45

本帖最后由 taller 于 2024-9-12 22:50 编辑

待更新代码

cnmlgb9998 · 发表于 2024-9-12 13:20

是这个效果吗？？？？？？？？？？？？

用PQ解决，难道，就真的不香？？？？？？？？？？？？？？？？？

ddz79101 · 发表于 2024-9-12 13:54

chxw68 发表于 2024-9-12 09:10
不太好处理，抛砖引玉吧。

谢谢老师！运行后只生成了一行合计数。不知什么原因

ddz79101 · 发表于 2024-9-12 13:56

mjm04 发表于 2024-9-12 10:32
原始数据相当不友好！乱的一B啊

WPS-正则参与一下下，开个火车车最后的汇总金额，自己SUM一下吧 ...

谢谢老师！我只有EXCEL.收藏了

		自动登录	找回密码
密码			免费注册

[求助] 分拆

评分

评分

评分

评分

评分