WORD文档如何能自动排列日期及星期？

壹号公馆 · 发表于 2018-3-1 14:18

WORD文档如何能自动排列日期及星期？

413191246se · 发表于 2018-3-16 00:47

楼主，我添加了3年的表格，请仔细核对每一个月的星期是否正确；并且根据页边距做了3种文档（原版（你的原版）、默认A43.17cm的边距、2.5cm边距），可以任选其一来正式使用。

工作日志(demo).rar (96.48 KB, 下载次数: 8)

413191246se · 发表于 2018-3-2 19:22

*请楼主备份原文件后应用下面的宏。
*请确保第1个月份必须是31天，否则出错！
*请自行命名下面的宏，本宏在Word2003下测试通过。
*请认真仔细核对每个月的日期／星期是否一一对应。
*请耐心等待程序运行完毕，如果增加月份超过10个以上的话。
*程序算法不高明，但我认为结果还算正确（以附件为准），楼主试试吧！

Sub test()
On Error Resume Next
Dim doc As Document, i$, j$, k$, p$, q&
Set doc = ActiveDocument
inp:
p = InputBox("* 输入 3 则增加 3 个月的表格！" & vbCr & vbCr & "* 首页表格天数必须是31天，否则出错！", "请输入增加月份的个数（正整数1或2位）", "1")
If p = "" Then End
If Not (p Like "[1-9]" Or p Like "[1-9][0-9]") Then GoTo inp
For q = 1 To p
'最终表格日期
doc.Tables(doc.Tables.Count).Select
Selection.MoveUp unit:=wdParagraph, Count:=2
i = Right(Selection.Paragraphs(1).Range, 10)
i = Replace(i, " ", "")
i = Replace(i, vbCr, "")
j = Left(i, 4)
k = Mid(i, 6, 2)
k = Replace(k, "月", "")
'复制第1页的表格(必须31天，否则出错)
doc.Tables(1).Range.Next(unit:=wdParagraph, Count:=1).Select
With Selection
.EndKey unit:=wdLine
.HomeKey unit:=wdStory, Extend:=wdExtend
.Copy
.EndKey unit:=wdStory
.InsertBreak
.Paste
doc.Characters.First.Copy '变相清空剪贴板
'选中当前页第2段
doc.Tables(doc.Tables.Count).Select
Selection.MoveUp unit:=wdParagraph, Count:=2
Selection.EndKey unit:=wdLine
Do
Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop Until Selection Like " *"
Selection.MoveStart unit:=wdCharacter, Count:=1
End With
'赋值
If k = 12 Then k = 1: j = j + 1 Else k = k + 1
Selection.Text = j & "年" & k & "月"
'd=本月天数
Dim MyDate, MyMonth, d&
MyDate = k & "/1/" & j
d = Day(DateValue(Year(MyDate) & -Month(MyDate) - 1 & -1) - 1)
If k = 12 Then d = 31
'删除最终表格最后一行（次数）
Dim x&
If d > 0 Then
For x = 1 To 31 - d
doc.Tables(doc.Tables.Count).Rows.Last.Delete
Next x
End If
'判断每月1号是星期几
Dim s$
s = j & "-" & k & "-1"
s = WeekdayName(Weekday(s))
Dim a$, b&
a = Right(s, 1)
If a = "一" Then b = 1
If a = "二" Then b = 2
If a = "三" Then b = 3
If a = "四" Then b = 4
If a = "五" Then b = 5
If a = "六" Then b = 6
If a = "日" Then b = 7
doc.Tables(doc.Tables.Count).Cell(2, 2).Range.Text = b
Dim h&
doc.Tables(doc.Tables.Count).Cell(3, 2).Range.Select
h = Selection.Tables(1).Rows.Count '最大行数
b = b + 1
doc.Range(Start:=doc.Tables(doc.Tables.Count).Cell(3, 2).Range.Start, End:=doc.Tables(doc.Tables.Count).Cell(h, 2).Range.End).Select
Dim c As Cell, r As Range
For Each c In Selection.Cells
Set r = c.Range
If b > 7 Then b = b - 7
r.Text = b
b = b + 1
Next
doc.Range(Start:=doc.Tables(doc.Tables.Count).Cell(2, 2).Range.Start, End:=doc.Tables(doc.Tables.Count).Cell(h, 2).Range.End).Select
For Each c In Selection.Cells
Set r = c.Range
r.MoveEnd unit:=wdCharacter, Count:=-1
If r.Text = 1 Then
r.Text = "一"
ElseIf r.Text = 2 Then
r.Text = "二"
ElseIf r.Text = 3 Then
r.Text = "三"
ElseIf r.Text = 4 Then
r.Text = "四"
ElseIf r.Text = 5 Then
r.Text = "五"
ElseIf r.Text = 6 Then
r.Text = "六"
ElseIf r.Text = 7 Then
r.Text = "日"
End If
Next
Next q
Selection.HomeKey unit:=wdStory
MsgBox "处理完毕！！！！！！！！！！！！", 0 + 48
End Sub

复制代码

壹号公馆 · 发表于 2018-3-15 18:53

413191246se 发表于 2018-3-2 19:22
*请楼主备份原文件后应用下面的宏。
*请确保第1个月份必须是31天，否则出错！
*请自行命名下面的宏，本宏 ...

不好意思，本人菜鸟一枚，请你帮忙做份文档出来，谢谢！

壹号公馆 · 发表于 2018-3-16 10:56

413191246se 发表于 2018-3-16 00:47
楼主，我添加了3年的表格，请仔细核对每一个月的星期是否正确；并且根据页边距做了3种文档（原版（你的原版 ...

谢谢！辛苦了！

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

[求助] WORD文档如何能自动排列日期及星期？

评分

评分