复制，分拆

石来运转6888

请老师使用VBA，非常感谢。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("原表")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:h" & r)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
   
9.     For i = 1 To UBound(arr)
   
10.         brr(i, 1) = arr(i, 1)
    
11.         brr(i, 2) = arr(i, 8)
    
12.         brr(i, 3) = arr(i, 7)
    
13.         brr(i, 4) = CDate(Format(arr(i, 2), "0000-00-00"))
    
14.         If Len(arr(i, 3)) <> 0 Then
    
15.             brr(i, 5) = CDate(Format(arr(i, 3), "00:00") & ":00")
    
16.         End If
    
17.         brr(i, 6) = Val(arr(i, 4))
    
18.         brr(i, 7) = Val(arr(i, 5))
    
19.         If Len(arr(i, 6)) > 1 Then
    
20.             xm = Split(arr(i, 6), "/")
    
21.             If UBound(xm) > 0 Then
    
22.                 brr(i, 8) = xm(0)
    
23.                 brr(i, 9) = xm(1)
    
24.             Else
    
25.                 brr(i, 9) = xm(0)
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     With Worksheets("生成新表")
    
30.         .UsedRange.Offset(1, 0).ClearContents
    
31.         .Range("b2:b" & 1 + UBound(brr) & ",h2:h" & 1 + UBound(brr)).NumberFormatLocal = "@"
    
32.         .Range("d2:d" & 1 + UBound(brr)).NumberFormatLocal = "yyyy/mm/dd"
    
33.         .Range("e2:e" & 1 + UBound(brr)).NumberFormatLocal = "hh:mm"
    
34.         .Range("f2:g" & 1 + UBound(brr)).NumberFormatLocal = "0.00"
    
35.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
36.     End With
    
37. End Sub
    

复制代码

chxw68

详见附件。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.19
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set reg = CreateObject("VBScript.Regexp")
   
5.     With Sheets("原表")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         .UsedRange.Offset(r).Clear
   
8.         arr = .[a1].Resize(r, 8)
   
9.     End With
   
10.     b = [{1,8,7,2,3,4,5,6}]
    
11.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
    
12.     On Error Resume Next
    
13.     With reg
    
14.         .Global = True
    
15.         .Pattern = "(\d+)"
    
16.         For i = 2 To UBound(arr)
    
17.             If arr(i, 1) <> Empty Then
    
18.                 m = m + 1
    
19.                 For j = 1 To UBound(b)
    
20.                     brr(m, j) = arr(i, b(j))
    
21.                 Next
    
22.                 rq = CStr(arr(i, 2))
    
23.                 brr(m, 4) = Left(rq, 4) & "/" & Mid(rq, 5, 2) & "/" & Mid(rq, 7, 2)
    
24.                 sj = CStr(arr(i, 3))
    
25.                 brr(m, 5) = IIf(sj = "", "", Left(sj, 2) & ":" & Mid(sj, 3, 2))
    
26.                 st = arr(i, b(8))
    
27.                 If st = "短信费" Then brr(m, 8) = "": brr(m, 9) = "短信费"
    
28.                 If st = "/" Then brr(m, 8) = "": brr(m, 9) = ""
    
29.                 If InStr(st, "/") Then
    
30.                     brr(m, 8) = Split(st, "/")(0): brr(m, 9) = Split(st, "/")(1)
    
31.                 Else
    
32.                     Set mh = .Execute(st)
    
33.                     brr(m, 8) = CStr(mh(0).Value)
    
34.                     brr(m, 9) = Replace(st, brr(m, 8), "")
    
35.                 End If
    
36.             End If
    
37.         Next
    
38.     End With
    
39.     With Sheets("生成新表")
    
40.         .[a1].Resize(1, 9).Interior.Color = 49407
    
41.         .UsedRange.Offset(1) = ""
    
42.         .Columns("A:e,h:i").NumberFormatLocal = "@"
    
43.         .Columns(4).NumberFormatLocal = "yyyy/m/d"
    
44.         With .[a2].Resize(m, 9)
    
45.             .Value = brr
    
46.             .Borders.LineStyle = 1
    
47.             .HorizontalAlignment = xlCenter
    
48.             .VerticalAlignment = xlCenter
    
49.         End With
    
50.     End With
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码

蓝桥玄霜

复制的例子：

cnmlgb9998

用PQ 简简单单！！！！ 看看就几行代码搞定，还能自动更新！！！！ 不香么？？？？


看看VBA 用了多少行代码实现？？？？

cnmlgb9998

我就问你们，PQ解决这种问题，香，还是不香？？？？？？？？？？？？

cnmlgb9998

此题，PQ 完胜。老师同意否？？？？？？？哈哈哈

ykcbf1100

cnmlgb9998 发表于 2024-4-19 11:38
我就问你们，PQ解决这种问题，香，还是不香？？？？？？？？？？？？

你没有附件，对楼主没有帮助的，代码再少也等于0，还有日期和时间没有拆分。