[已解决]如何使用VBA快速批量生成年工作表？

plues · 发表于 2011-10-15 23:42

本帖最后由 plues 于 2011-10-17 10:51 编辑

各位老师：

有一表格，需用ＶＢＡ按照模板生成１２个月的工作表，表名形如１月、２月.....１２月，且每月的工作表中，从第Ａ列的第9行开始，以本月的第1天到最后1天生成本月的行记录，该月有多少天，就生成多少行。如果该月为31天，直接从模板复制所有数据，生成日期即可；如果该月少于31天，则截取实际天数的数据并生成日期。除附件中Ａ列红色方框区域外，其它行列数据及公式均保持不变，请问是否可以实现？

恳请出手相助！谢谢！

示意图

最佳答案

月排行榜 / 总排行榜

爱疯

2011-10-17 00:12

demo3.rar (22.46 KB, 下载次数: 168)

zjdh · 发表于 2011-10-16 16:37

你不传附件，难道还要别人给你做模板？

plues · 发表于 2011-10-16 17:21

回复 zjdh 的帖子

zjdh老师批评的对，

这就把模板火速补上。请见附件demo.xls。

模板中已含有可批量复制生成1-12月份的工作表的VBA，但生成的工作表A列都是从1-31，不能根据月份天数的多少智能生成该月的日期行记录。

期望工作表1可从模板复制生成A列第9行开始1月1日~1月31日的记录；同理，工作表2为2月1日~2月28日；工作表3为3月1日~3月31日....工作表12为12月1日~12月31日。其它行列数据不变。

请zjdh老师及其他前辈不吝赐教！

demo.rar (7.97 KB, 下载次数: 33)

爱疯 · 发表于 2011-10-16 20:11

回复 plues 的帖子

Sub test()
Dim sh As Worksheet
Dim i As Integer, j As Integer, r As Integer
Dim arr(1 To 12) As Integer
'防出错
If Sheets.Count > 1 Then
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "模板" Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = False
For i = 1 To 12
'求天数
If i = 12 Then
arr(i) = Day(DateSerial(Year(Date) + 1, 1, 1) - 1)
Else
arr(i) = Day(DateSerial(Year(Date), i + 1, 1) - 1)
End If
'添加新的工作表
r = 8
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = i & "月"
'复制数据
With Sheets(i & "月")
'天数
For j = 1 To arr(i)
.Cells(j + r, 1) = j
Next j
.Range("A9:A" & arr(i) + r).Borders.LineStyle = 1
'标题行
Sheets(1).Range("A8:E8").Copy Destination:=.Range("A8")
'记录
Sheets(1).Range("B9:E" & arr(i) + r).Copy Destination:=.Range("B9")
End With
Next i
Sheets(1).Select
End Sub

复制代码

demo2.rar (16.62 KB, 下载次数: 34)

fjmxwrs · 发表于 2011-10-16 20:58

回复 plues 的帖子

Sub test()
Dim i&, j&, iDateD&
Dim she As Worksheet
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
For Each she In Sheets
If she.Name <> "模板" Then she.Delete
Next she
End If
For i = 1 To 12
iDateD = Day(DateSerial(Format(Date, "yyyy"), i + 1, 0))
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = i & "月"
With Sheets(i & "月")
Sheets("模板").Range("A8").Resize(iDateD + 1, 5).Copy .Range("A8")
For j = 1 To iDateD
.Cells(j + 8, 1) = i & "月" & j & "日"
Next j
End With
Next
Application.DisplayAlerts = True
End Sub

复制代码

demo.zip (19.95 KB, 下载次数: 36)

plues · 发表于 2011-10-16 22:15

回复爱疯的帖子

感谢“爱疯”及“fjmxwrs”两位版主热心帮助！在此一并致谢！

经测试，两组代码均运行正常，符合实际需要，太棒了！

额外想再添加２个需求，希望程序更加完美，烦请两位版主再补充一下代码。

需求1：在原模板的基础上，在最末行又增加了一个行(见修改后的附件中红色的尾行)，此行用于合并统计，用来对每月工作表中从月初到月末区域中的的所有列进行求和。模板中尾行已自带公式，只需在现有代码处理结果后，将模板尾行自动添加到每月的工作表中的最末行。

需求2：假设将模板中默认行高设定为20，最佳的效果是生成的12张工作表默认行高都是20。测试结果发现，生成的工作表行高都小于原模板行高。

fjmxwrs版主的日期一栏为“X月X日”，显示更为直观。爱疯版主代码中有注释，有助于增强理解。

demo2.rar (12.57 KB, 下载次数: 11)

爱疯 · 发表于 2011-10-17 00:12

demo3.rar (22.46 KB, 下载次数: 168)

plues · 发表于 2011-10-17 10:46

问题已圆满解决。有此类问题的坛友，可观摩学习以上代码。
再次感谢“爱疯”及“fjmxwrs”两位版主！

fjmxwrs · 发表于 2011-10-17 10:53

学习爱疯老师的代码

爱疯 · 发表于 2011-10-17 12:04

我也是向fj学习了，0的用法虽然知道，但由于很少用，就忘了，这次用了就又又印象了。
fj后面整块区域复制的方式，也是更省的办法，还是自己没多想。
要到说静就静，还得好好修炼{:241:}

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

[已解决]如何使用VBA快速批量生成年工作表？

评分

评分