利用 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)

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

'生成日历

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

' '以下部分是为了美化输出，如搂住不需要可以将以下部分完全注释掉

' 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 9), 2)

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 + "0609 口香糖的结婚纪念日,"

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 + "1120*彝族年,"

strTmp = strTmp + "1121*彝族年,"

strTmp = strTmp + "1122*彝族年,"

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 + "0730 被奴役国家周,"

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 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

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

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

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月农历丙戌狗年

星期日

星期一

星期二

星期三

星期四

星期五

星期六

劳动节

青年节

初八

立夏

李四摧

周五输

吴六破

郑七灭

王八衰

鹤笔翁

十日

世界红十字日

十二

十三

十四

国际护士节

十六

赵一伤

钱二败

孙三毁

李四摧

周五输

吴六破

郑七灭

十七

国际家庭日

十九

国际电信日

廿一

廿二

廿三

王八衰

鹤笔翁

赵一伤

钱二败

孙三毁

李四摧

周五输

小满

廿五

廿六

廿七

廿八

廿九

五月

吴六破

郑七灭

王八衰

鹤笔翁

赵一伤

钱二败

孙三毁

初二

初三

初四

端午节

李四摧

周五输

吴六破

郑七灭