求助如何提取数据转换成按天的明细表

dagal

求助将班结表黄色区域的内容转换成签单明细表的模板，打印时能按天直接打印输出？


Desktop.rar (33.13 KB, 下载次数: 4)

2023-2-23 17:30 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     With Worksheets("应收账")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
10.         arr = .Range("a1").Resize(r, c)
    
11.     End With
    
12.     For j = 2 To UBound(arr, 2) - 1
    
13.         ReDim brr(1 To UBound(arr), 1 To 4)
    
14.         m = 0
    
15.         s = 0
    
16.         For i = 2 To UBound(arr)
    
17.             If arr(i, 1) <> "消费金额" And Len(arr(i, j)) <> 0 Then
    
18.                 m = m + 1
    
19.                 brr(m, 1) = m
    
20.                 brr(m, 2) = arr(i, 1)
    
21.                 brr(m, 3) = arr(i, j)
    
22.                 s = s + arr(i, j)
    
23.             End If
    
24.         Next
    
25.         If m > 0 Then
    
26.             m = m + 1
    
27.             brr(m, 2) = "合计"
    
28.             brr(m, 3) = s
    
29.             shtname = CStr(Day(arr(1, j)))
    
30.             On Error Resume Next
    
31.             Set ws = Worksheets(shtname)
    
32.             If Err Then
    
33.                 Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
34.                 ws.Name = shtname
    
35.             End If
    
36.             On Error GoTo 0
    
37.             With ws
    
38.                 .Cells.Clear
    
39.                 With .Range("a1")
    
40.                     .Value = "签单明细表"
    
41.                     .Resize(1, 4).Merge
    
42.                     With .Font
    
43.                         .Name = "微软雅黑"
    
44.                         .Size = 16
    
45.                         .Bold = True
    
46.                     End With
    
47.                 End With
    
48.                 .Range("a2") = "日期："
    
49.                 With .Range("b2")
    
50.                     .Value = arr(1, j)
    
51.                     .NumberFormatLocal = "yyyy年m月d日"
    
52.                 End With
    
53.                 .Range("a3:d3") = Array("序号", "单位", "金额", "备注")
    
54.                 .Range("a4").Resize(m, 4) = brr
    
55.                 With .Range("a3").Resize(1 + m, 4)
    
56.                     .Borders.LineStyle = xlContinuous
    
57.                     With .Font
    
58.                         .Name = "微软雅黑"
    
59.                         .Size = 10
    
60.                     End With
    
61.                 End With
    
62.                 With .UsedRange
    
63.                     .HorizontalAlignment = xlCenter
    
64.                     .VerticalAlignment = xlCenter
    
65.                 End With
    
66.                 .Range("b2").HorizontalAlignment = xlLeft
    
67.                 .Columns(1).ColumnWidth = 7
    
68.                 .Columns(2).ColumnWidth = 30
    
69.                 .Columns(3).ColumnWidth = 7
    
70.                 .Columns(4).ColumnWidth = 15
    
71.                
    
72.             End With
    
73.         End If
    
74.     Next
    
75. End Sub
    

复制代码

chxw68

详见附件。

dagal

chxw68 发表于 2023-2-24 07:50

太厉害了，谢谢。就是有个不知算不算bug，提取后的每个表的日期不是前面那个总表的，会自动变成当年的，实际是想生成去年的。不行的话也问题不大就是，手动改下哪年哪月的也行，哈哈。总之，非常感谢大神帮忙。。。。

chxw68

dagal 发表于 2023-2-24 12:53
太厉害了，谢谢。就是有个不知算不算bug，提取后的每个表的日期不是前面那个总表的，会自动变成当年的， ...

日期取的是你的[应收账]表中第1行的日期，不会自动变的。