首先感谢各位大神对小弟上个帖子的无私帮助，小弟恬不知耻的再次请求帮助，拜谢！！

mao9998

数据.rar (9.74 KB, 下载次数: 6)

2024-1-17 10:11 上传

点击文件名下载附件
数据

直奔主题，保持附件“格式模板”中第一、二行的名头格式不变，把“数据”表中的数据填入模板相应的格中（数据填好后的效果如“示例”），并按照时间分类新建excel文件，新建的excel文件命名为“数据”表中时间，新建的文件只含有附件“示例”一个表格，表格内容是“数据”表中当天（新建的excel文件名的日期）的内容。   再次感谢大神的无私奉献！

mao9998

mao9998

请求大神不吝赐教

shiruiqiang

====小白路过====

ykcbf1100

shiruiqiang 发表于 2024-1-18 16:21
====小白路过====

你不能算小白了吧。

shiruiqiang

ykcbf1100 发表于 2024-1-18 16:26
你不能算小白了吧。

发帖要求大神答题，自我感觉稍微比小白好一点。
群里大神较多，还在学习他们的思路中

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.18
   
2.     Dim d, i%, arr, sh As Worksheet, sht As Worksheet, k, kk
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set sh = ThisWorkbook.Sheets("格式模板")
   
8.     arr = Sheets("内容数据").UsedRange
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 4)
    
11.         If arr(i, 1) <> Empty Then
    
12.             If Not d.Exists(s) Then
    
13.                 Set d(s) = CreateObject("scripting.dictionary")
    
14.             End If
    
15.             d(s)(i) = i
    
16.         End If
    
17.     Next i
    
18.     For Each k In d.keys
    
19.         fn = Format(k, "yyyy-m-d")
    
20.         sh.Copy
    
21.         Set wb = ActiveWorkbook
    
22.         m = 0
    
23.         ReDim brr(1 To d(k).Count, 1 To 6)
    
24.         With wb.Sheets(1)
    
25.             .Name = fn
    
26.             .[b1] = k
    
27.             For Each kk In d(k).keys
    
28.                 m = m + 1
    
29.                 For j = 1 To 3
    
30.                     brr(m, j) = arr(kk, j)
    
31.                 Next
    
32.                 For j = 4 To 6
    
33.                     brr(m, j) = arr(kk, j + 1)
    
34.                 Next
    
35.             Next
    
36.             .Columns(4).NumberFormatLocal = "0"
    
37.             With .[a3].Resize(m, 6)
    
38.                 .Value = brr
    
39.                 .Borders.LineStyle = 1
    
40.                 .HorizontalAlignment = xlCenter
    
41.                 .VerticalAlignment = xlCenter
    
42.             End With
    
43.             wb.SaveAs p & fn
    
44.             wb.Close 1
    
45.         End With
    
46.     Next k
    
47.     Sheets("内容数据").Activate
    
48.     Set d = Nothing
    
49.     Application.DisplayAlerts = True
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
52. End Sub
    

复制代码

ykcbf1100

按日期拆分的话，模板要改一下的（已改）

附件供参考。。。

ykcbf1100

shiruiqiang 发表于 2024-1-18 16:39
发帖要求大神答题，自我感觉稍微比小白好一点。
群里大神较多，还在学习他们的思路中

你太谦虚了。。。
在楼主眼里，你就是大神!

mao9998

shiruiqiang 发表于 2024-1-18 16:21
====小白路过====

十分感谢，认真学习