利用 wordXP 实现自动排班

许多工作岗位需要每天或每月排一次班,如何用WORD实现自动排班?笔者曾对此做过一些研究,不尽人意.

在一位网友(chewinggum(口香糖·把减肥列入下一个五年计划) )提供了很不错的代码(http://community.csdn.net/Expert/topic/4304/4304006.xml?temp=.7863428),稍做了一些改动,感觉效果还可以.

新建WORD文档,ALT+F11进入IDE界面.添加模块1并进行如下操作:

Thisdocument加入下面代码

Private Sub Document_Open()
Main
End Sub

模块1加入下面代码:

Option Explicit

Dim LunarInfo(0 To 149) As Long
Dim SolarMonth
Dim Gan
Dim Zhi
Dim Animals
Dim SolarTerm
Dim sTermInfo
Dim nStr1
Dim nStr2
Dim nStr3
Dim MonthName
Dim sFtv
Dim lFtv
Dim wFtv

Sub Main()

Application.ScreenUpdating = False
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Dim member As String
Dim m() As String
Dim InputYear As Integer '输入年
Dim InputMonth As Integer '输入年

Dim intTableRows As Integer '表格的列数
Dim intMonthDays As Integer '该月的天数
Dim intWeekDay As Integer '星期几
Dim intFirstDayWeek As Integer '第一天是星期几
Dim i As Integer

Initialize '初始化数据
member = InputBox("输入年月如" & Format(Date, "yyyy-mm"), "提示", Format(Date, "yyyy-mm"))

InputMonth = CInt(Right(member, 2))
InputYear = CInt(Left(member, 4))
member = InputBox("请输入值班者名单", "提示", "赵一伤,钱二败,孙三毁,李四摧,周五输,吴六破,郑七灭,王八衰,鹤笔翁")
m = Split(member, ",")
For i = 0 To UBound(m)
m(i) = i + 1 & " " & m(i)
Next
member = InputBox(Join(m, vbCrLf), "请选择上月最后一位值班者编号", "1")

'计算表格的列数
intMonthDays = SolarDays(InputYear, InputMonth)
intFirstDayWeek = Weekday(InputYear & "-" & InputMonth & "-1")
intTableRows = (intMonthDays + intFirstDayWeek - 1)
If intTableRows / 7 <> Int(intTableRows / 7) Then
intTableRows = Int(intTableRows / 7) + 1
Else
intTableRows = intTableRows / 7
End If


ActiveDocument.PageSetup.PaperSize = wdPaperA4
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=intTableRows * 2 + 2, NumColumns:= _
7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitWindow


Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Tables(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Tables(1).LeftPadding = CentimetersToPoints(0.05)
Selection.Tables(1).RightPadding = CentimetersToPoints(0.05)
Selection.Tables(1).Spacing = 0

'生成表头
Selection.Tables(1).Cell(1, 1).Select
Selection.SelectRow
Selection.Cells.Merge
Selection.Cells.Shading.BackgroundPatternColor = wdColorIndigo
Selection.Font.Size = 15
Selection.Font.Color = wdColorWhite
Selection.TypeText "公元" & InputYear & "年" & InputMonth & "月 "
Selection.Font.Color = wdColorYellow
Selection.TypeText "农历 " & cyclical(InputYear) & Animal(InputYear) & "年"
For i = 1 To 7
If i = 1 Or i = 7 Then
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorRed
Else
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorBlack
End If
Selection.Tables(1).Cell(2, i).Range.Font.Size = 15
Selection.Tables(1).Cell(2, i).Range.Font.Bold = True
Selection.Tables(1).Cell(2, i).Range.Text = " 星期" & nStr1(i - 1)
Selection.Tables(1).Cell(2, i).Shading.BackgroundPatternColor = wdColorYellow
Next

'生成日历
For i = 1 To intMonthDays
Dim intRow As Integer
Dim strDate As String
intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
intRow = ((intFirstDayWeek + i - 2) \ 7 + 1) * 2 + 1 '计算行位置

Dim strTmp As String
Dim lngColor As Long
strTmp = Trim(GetDayString(CDate((InputYear & "-" & InputMonth & "-" & i)), lngColor))

Selection.Tables(1).Cell(intRow, intWeekDay).Select
If intWeekDay = 1 Or intWeekDay = 7 Then
Selection.Font.Color = wdColorRed
ElseIf Left(strTmp, 1) = "*" Then
Selection.Font.Color = wdColorRed
strTmp = Replace(strTmp, "*", "")
Else
Selection.Font.Color = wdColorBlack
End If
Selection.Font.Size = 40
Selection.Font.Name = "Arial narrow"
Selection.Font.Bold = True
Selection.TypeText i
Selection.TypeText Chr(11)
If Len(strTmp) > 5 Then
Selection.Font.Size = 8
Else
Selection.Font.Size = 10
End If
Selection.Font.Name = "宋体"
Selection.Font.Color = lngColor
Selection.TypeText strTmp
Next
'
' With Selection.Tables(1)
' .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
' .Borders(wdBorderRight).LineStyle = wdLineStyleNone
' .Borders(wdBorderTop).LineStyle = wdLineStyleNone
' .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
' .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
' .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
' .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
' .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
' .Borders.Shadow = False
' End With


For i = 1 To intMonthDays
intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
intRow = ((intFirstDayWeek + i - 2) \ 7 + 1) * 2 + 2 '计算行位置
Selection.Tables(1).Cell(intRow, intWeekDay).Select
Selection.Font.Size = 16
Selection.TypeText Mid(m((CInt(member) + i - 1) Mod (ubound(m)+1) ), 2)

Next
Application.ScreenUpdating = True
End Sub

'数据初始化
Private Sub Initialize()
Dim strTmp As String
LunarInfo(0) = &H4BD8
LunarInfo(1) = &H4AE0
LunarInfo(2) = &HA570
LunarInfo(3) = &H54D5
LunarInfo(4) = &HD260
LunarInfo(5) = &HD950
LunarInfo(6) = &H16554
LunarInfo(7) = &H56A0
LunarInfo(8) = &H9AD0
LunarInfo(9) = &H55D2
LunarInfo(10) = &H4AE0
LunarInfo(11) = &HA5B6
LunarInfo(12) = &HA4D0
LunarInfo(13) = &HD250
LunarInfo(14) = &H1D255
LunarInfo(15) = &HB540
LunarInfo(16) = &HD6A0
LunarInfo(17) = &HADA2
LunarInfo(18) = &H95B0
LunarInfo(19) = &H14977
LunarInfo(20) = &H4970
LunarInfo(21) = &HA4B0
LunarInfo(22) = &HB4B5
LunarInfo(23) = &H6A50
LunarInfo(24) = &H6D40
LunarInfo(25) = &H1AB54
LunarInfo(26) = &H2B60
LunarInfo(27) = &H9570
LunarInfo(28) = &H52F2
LunarInfo(29) = &H4970
LunarInfo(30) = &H6566
LunarInfo(31) = &HD4A0
LunarInfo(32) = &HEA50
LunarInfo(33) = &H6E95
LunarInfo(34) = &H5AD0
LunarInfo(35) = &H2B60
LunarInfo(36) = &H186E3
LunarInfo(37) = &H92E0
LunarInfo(38) = &H1C8D7
LunarInfo(39) = &HC950
LunarInfo(40) = &HD4A0
LunarInfo(41) = &H1D8A6
LunarInfo(42) = &HB550
LunarInfo(43) = &H56A0
LunarInfo(44) = &H1A5B4
LunarInfo(45) = &H25D0
LunarInfo(46) = &H92D0
LunarInfo(47) = &HD2B2
LunarInfo(48) = &HA950
LunarInfo(49) = &HB557
LunarInfo(50) = &H6CA0
LunarInfo(51) = &HB550
LunarInfo(52) = &H15355
LunarInfo(53) = &H4DA0
LunarInfo(54) = &HA5D0
LunarInfo(55) = &H14573
LunarInfo(56) = &H52D0
LunarInfo(57) = &HA9A8
LunarInfo(58) = &HE950
LunarInfo(59) = &H6AA0
LunarInfo(60) = &HAEA6
LunarInfo(61) = &HAB50
LunarInfo(62) = &H4B60
LunarInfo(63) = &HAAE4
LunarInfo(64) = &HA570
LunarInfo(65) = &H5260
LunarInfo(66) = &HF263
LunarInfo(67) = &HD950
LunarInfo(68) = &H5B57
LunarInfo(69) = &H56A0
LunarInfo(70) = &H96D0
LunarInfo(71) = &H4DD5
LunarInfo(72) = &H4AD0
LunarInfo(73) = &HA4D0
LunarInfo(74) = &HD4D4
LunarInfo(75) = &HD250
LunarInfo(76) = &HD558
LunarInfo(77) = &HB540
LunarInfo(78) = &HB5A0
LunarInfo(79) = &H195A6
LunarInfo(80) = &H95B0
LunarInfo(81) = &H49B0
LunarInfo(82) = &HA974
LunarInfo(83) = &HA4B0
LunarInfo(84) = &HB27A
LunarInfo(85) = &H6A50
LunarInfo(86) = &H6D40
LunarInfo(87) = &HAF46
LunarInfo(88) = &HAB60
LunarInfo(89) = &H9570
LunarInfo(90) = &H4AF5
LunarInfo(91) = &H4970
LunarInfo(92) = &H64B0
LunarInfo(93) = &H74A3
LunarInfo(94) = &HEA50
LunarInfo(95) = &H6B58
LunarInfo(96) = &H55C0
LunarInfo(97) = &HAB60
LunarInfo(98) = &H96D5
LunarInfo(99) = &H92E0
LunarInfo(100) = &HC960
LunarInfo(101) = &HD954
LunarInfo(102) = &HD4A0
LunarInfo(103) = &HDA50
LunarInfo(104) = &H7552
LunarInfo(105) = &H56A0
LunarInfo(106) = &HABB7
LunarInfo(107) = &H25D0
LunarInfo(108) = &H92D0
LunarInfo(109) = &HCAB5
LunarInfo(110) = &HA950
LunarInfo(111) = &HB4A0
LunarInfo(112) = &HBAA4
LunarInfo(113) = &HAD50
LunarInfo(114) = &H55D9
LunarInfo(115) = &H4BA0
LunarInfo(116) = &HA5B0
LunarInfo(117) = &H15176
LunarInfo(118) = &H52B0
LunarInfo(119) = &HA930
LunarInfo(120) = &H7954
LunarInfo(121) = &H6AA0
LunarInfo(122) = &HAD50
LunarInfo(123) = &H5B52
LunarInfo(124) = &H4B60
LunarInfo(125) = &HA6E6
LunarInfo(126) = &HA4E0
LunarInfo(127) = &HD260
LunarInfo(128) = &HEA65
LunarInfo(129) = &HD530
LunarInfo(130) = &H5AA0
LunarInfo(131) = &H76A3
LunarInfo(132) = &H96D0
LunarInfo(133) = &H4BD7
LunarInfo(134) = &H4AD0
LunarInfo(135) = &HA4D0
LunarInfo(136) = &H1D0B6
LunarInfo(137) = &HD250
LunarInfo(138) = &HD520
LunarInfo(139) = &HDD45
LunarInfo(140) = &HB5A0
LunarInfo(141) = &H56D0
LunarInfo(142) = &H55B2
LunarInfo(143) = &H49B0
LunarInfo(144) = &HA577
LunarInfo(145) = &HA4B0
LunarInfo(146) = &HAA50
LunarInfo(147) = &H1B255
LunarInfo(148) = &H6D20
LunarInfo(149) = &HADA0

SolarMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Gan = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
Zhi = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
Animals = Array("鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴", "鸡", "狗", "猪")
SolarTerm = Array("小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")
sTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)
nStr1 = Array("日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
nStr2 = Array("初", "十", "廿", "卅", "　")
MonthName = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")

'国历节日 *表示放假日
strTmp = ""
strTmp = strTmp + "0101*元旦,"
strTmp = strTmp + "0214 情人节,"
strTmp = strTmp + "0305 学雷锋纪念日,"
strTmp = strTmp + "0308 妇女节,"
strTmp = strTmp + "0312 植树节,"
strTmp = strTmp + "0315 消费者权益日,"
strTmp = strTmp + "0401 愚人节,"
strTmp = strTmp + "0407 世界卫生日,"
strTmp = strTmp + "0422 世界地球日,"
strTmp = strTmp + "0501*劳动节,"
strTmp = strTmp + "0502*劳动节,"
strTmp = strTmp + "0503*劳动节,"
strTmp = strTmp + "0504 青年节,"
strTmp = strTmp + "0508 世界红十字日,"
strTmp = strTmp + "0512 国际护士节,"
strTmp = strTmp + "0515 国际家庭日,"
strTmp = strTmp + "0517 国际电信日,"
strTmp = strTmp + "0601 国际儿童节,"
strTmp = strTmp + "0605 世界环境保护日,"
strTmp = strTmp + "0606 全国爱眼日,"
strTmp = strTmp + "0625 全国土地日,"
strTmp = strTmp + "0626 国际禁毒日,"
strTmp = strTmp + "0701 香港回归纪念日 中共诞辰,"
strTmp = strTmp + "0707 抗日战争纪念日,"
strTmp = strTmp + "0801 建军节,"
strTmp = strTmp + "0815 抗日战争胜利纪念,"
strTmp = strTmp + "0909 逝世纪念,"
strTmp = strTmp + "0908 国际扫盲日,"
strTmp = strTmp + "0910 中国教师节,"
strTmp = strTmp + "0927 世界旅游日,"
strTmp = strTmp + "0928 孔子诞辰,"
strTmp = strTmp + "1001*国庆节,"
strTmp = strTmp + "1002*国庆节,"
strTmp = strTmp + "1003*国庆节,"
strTmp = strTmp + "1006 老人节,"
strTmp = strTmp + "1009 世界邮政日,"
strTmp = strTmp + "1014 世界标准日,"
strTmp = strTmp + "1016 世界粮食日,"
strTmp = strTmp + "1024 联合国日,"
strTmp = strTmp + "1112 孙中山诞辰纪念,"
strTmp = strTmp + "1205 国际志愿人员日,"
strTmp = strTmp + "1220 澳门回归纪念,"
strTmp = strTmp + "1225 圣诞节"
strTmp = strTmp + "1226 诞辰纪念"

sFtv = Split(strTmp, ",")

'农历节日 *表示放假日
strTmp = ""

strTmp = strTmp + "0101*春节,"
strTmp = strTmp + "0102*春节,"
strTmp = strTmp + "0103*春节,"
strTmp = strTmp + "0115 元宵节,"
strTmp = strTmp + "0505 端午节,"
strTmp = strTmp + "0624*火把节,"
strTmp = strTmp + "0625*火把节,"
strTmp = strTmp + "0626*火把节,"
strTmp = strTmp + "0707 七夕情人节,"
strTmp = strTmp + "0715 中元节,"
strTmp = strTmp + "0815 中秋节,"
strTmp = strTmp + "0909 重阳节,"
strTmp = strTmp + "1208 腊八节,"
strTmp = strTmp + "1224 小年,"
strTmp = strTmp + "0100 除夕"

lFtv = Split(strTmp, ",")

'某月的第几个星期几
strTmp = ""
strTmp = strTmp + "0520 母亲节,"
strTmp = strTmp + "0630 父亲节,"
strTmp = strTmp + "1144 感恩节"
wFtv = Split(strTmp, ",")
End Sub

'传回农历 y年的总天数

Private Function lYearDays(ByVal Y As Integer) As Integer
Dim i, Sum As Double
Sum = 0
For i = 1 To 12
Sum = Sum + lMonthDays(Y, i)
Next i
lYearDays = Sum + LeapDays(Y)
End Function

'传回农历 y年闰月的天数
Private Function LeapDays(ByVal Y As Integer) As Integer
Dim m As Integer
Dim l As Double
m = LeapMonth(Y)
If m = 0 Then
LeapDays = 0
Else
l = LunarInfo(Y - 1900)
'l = LunarInfo(Y - 1900 + 1)
If l < 0 Then l = l * (-1)
l = (l And &H10000)
If l = 0 Then
LeapDays = 29
Else
LeapDays = 30
End If
End If
End Function

'传回农历 y年闰哪个月 1-12 , 没闰传回 0 OK

Private Function LeapMonth(ByVal Y As Integer) As Integer
LeapMonth = 0
If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900) And &HF)
End Function

'传回农历 y年m月的总天数 OK-

Private Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If Y < 1900 Then Y = 1900
If (LunarInfo(Y - 1900) And Int(&H10000 / (2 ^ m))) = 0 Then
'If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then
lMonthDays = 29
Else
lMonthDays = 30
End If
End Function

'根据给定的阳历，返回农历的日期

Private Function GetLunar(ByVal SolarDate As Date) As String
Dim DaysOffset As Long
Dim i As Integer
Dim Temp As Long
Dim lyear, lmonth, lday As Integer
DaysOffset = SolarDate - CDate("1900-1-31")
i = 1900
Do While i < 2050 And DaysOffset >= 0
Temp = lYearDays(i)
DaysOffset = DaysOffset - Temp
i = i + 1
Loop
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lyear = i

Dim Leap As Integer
Dim IsLeap As Boolean
Leap = LeapMonth(i)
IsLeap = False
i = 1
Do While i < 13 And DaysOffset > 0
If Leap > 0 And i = (Leap + 1) And IsLeap = False Then
i = i - 1
IsLeap = True
Temp = LeapDays(lyear)
Else
Temp = lMonthDays(lyear, i)
End If
If IsLeap And i = (Leap + 1) Then IsLeap = False
DaysOffset = DaysOffset - Temp
i = i + 1
Loop

If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then
If IsLeap Then
IsLeap = False
Else
IsLeap = True
i = i - 1
End If
End If
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lmonth = i
lday = DaysOffset + 1

'返回特殊标志的字符串

If IsLeap Then

'GetLunar = "0000【" & Animal(lyear) & "】" & cyclical(lyear) & "年闰" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日" & GetTerm(SolarDate)
GetLunar = "1" & lyear & Format(lmonth, "00") & Format(lday, "00")
Else
GetLunar = "0" & lyear & Format(lmonth, "00") & Format(lday, "00")
'GetLunar = Format(lmonth, "00") & Format(lday, "00") & "【" & Animal(lyear) & "】" & cyclical(lyear) & "年" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日 " & GetTerm(SolarDate)
End If
End Function

'传回阳历 y年某m月的天数 OK

Private Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If m = 2 Then
If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then
SolarDays = 29
Else
SolarDays = 28
End If
Else
SolarDays = SolarMonth(m - 1)
End If
End Function

'某y年的第n个节气的日期(从0小寒起算) OK

Private Function sTerm(ByVal Y, n As Integer) As Date
Dim D1, D2 As Double
D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)
D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1
D1 = D2 / 2
sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0"))
sTerm = Format(sTerm, "yyyy/mm/dd")
End Function

'根据年份返回属象 OK
Private Function Animal(ByVal sYear As Integer) As String
Animal = Animals((sYear - 1900) Mod 12)
End Function

'根据阳历返回其节气，若不是则返回空 OK
Private Function GetTerm(ByVal sDate As Date) As String
Dim Y, m As Integer
Y = Year(sDate)
m = Month(sDate)
GetTerm = ""
If sTerm(Y, m * 2 - 1) = sDate Then
GetTerm = SolarTerm(m * 2 - 1)
ElseIf sTerm(Y, m * 2 - 2) = sDate Then
GetTerm = SolarTerm(m * 2 - 2)
End If
End Function

'根据阳历返回其节日，若不是则返回空 OK
Private Function GetFeast(ByVal sDate As Date) As String
Dim i As Integer
Dim strTmp As String
strTmp = Format(sDate, "MMDD")
For i = LBound(sFtv) To UBound(sFtv)
If Left(sFtv(i), 4) = strTmp Then
GetFeast = Mid(sFtv(i), 5, Len(sFtv(i)) - 4)
Exit Function
End If
Next
GetFeast = ""
End Function

'根据阴历返回其节日，若不是则返回空 OK
Private Function GetLunarFeast(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
strTmp = Right(sDate, 4)
For i = LBound(lFtv) To UBound(lFtv)
If Left(lFtv(i), 4) = strTmp Then
GetLunarFeast = Mid(lFtv(i), 5, Len(lFtv(i)) - 4)
Exit Function
End If
Next
GetLunarFeast = ""
End Function

'根据阴历返回其字符串 OK
Private Function GetLunarString(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
Dim strMonth As String
Dim strDay As String

strMonth = Left(sDate, 2)
strDay = Right(sDate, 2)
If strDay = "01" Then
GetLunarString = nStr1(Val(strMonth)) & "月"
ElseIf strDay = "20" Then
GetLunarString = "二十"
ElseIf strDay = "30" Then
GetLunarString = "三十"
Else
GetLunarString = nStr2(Val(Left(strDay, 1))) & nStr1(Val(Right(strDay, 1)))
End If
End Function

'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日
Private Function GetMonthWeek(ByVal sDate As Date) As String
Dim D0 As Date
D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")
GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1
End Function

'天干地支计算 OK
Private Function cyclical(num) As String
cyclical = Gan((num - 1864) Mod 10) + Zhi((num - 1864) Mod 12)
End Function

'获取农历或节日说明
Private Function GetDayString(ByVal sDate As Date, ByRef lngColor As Long) As String
Dim strLunarDate As String
Dim strTmp As String
strTmp = GetTerm(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbGreen: Exit Function
strTmp = GetFeast(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbBlue: Exit Function
strLunarDate = GetLunar(sDate)
strTmp = GetLunarFeast(Right(strLunarDate, 4))
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbRed: Exit Function
strTmp = GetLunarString(Right(strLunarDate, 4))
lngColor = vbBlack:
GetDayString = strTmp
End Function

保存即可.以后打开文档会自动进行排班,效果如下:

公元 2006 年 5 月 农历 丙戌狗年
星期日	星期一	星期二	星期三	星期四	星期五	星期六
	1 劳动节	2 劳动节	3 劳动节	4 青年节	5 初八	6 立夏
	李四摧	周五输	吴六破	郑七灭	王八衰	鹤笔翁
7 十日	8 世界红十字日	9 十二	10 十三	11 十四	12 国际护士节	13 十六
赵一伤	钱二败	孙三毁	李四摧	周五输	吴六破	郑七灭
14 十七	15 国际家庭日	16 十九	17 国际电信日	18 廿一	19 廿二	20 廿三
王八衰	鹤笔翁	赵一伤	钱二败	孙三毁	李四摧	周五输
21 小满	22 廿五	23 廿六	24 廿七	25 廿八	26 廿九	27 五月
吴六破	郑七灭	王八衰	鹤笔翁	赵一伤	钱二败	孙三毁
28 初二	29 初三	30 初四	31 端午节
李四摧	周五输	吴六破	郑七灭