全年日历

zopey

A1单元格输入1900- 2100区间 指定年份后，一键更新全年日历。

（现有农历、四柱、节气、节日、纪念日等信息）
打开节日隐藏工作表后， 可自行修改。

全年日历.zip (85.64 KB, 下载次数: 2088)

2018-2-8 15:21 上传

点击文件名下载附件

zopey

Private Sub CommandButton1_Click()
Dim T, D, N, F
Rows("2:65535").ClearContents

A = Cells(1, 1).Value
For i = 1 To DateDiff("d", A & "-1-1", A + 1 & "-1-1")
    Cells(i + 1, 1).Value = DateAdd("d", i - 1, A & "-1-1")
    Cells(i + 1, 2).Value = lunar(Cells(i + 1, 1).Value)
    Cells(i + 1, 3).Value = sizhu(Cells(i + 1, 1).Value)
Next

T = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
D = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
N = Array("一", "二", "三", "四", "五", "六", "七", "八", "九")
F = Array("小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")
For i = 0 To 23
   j = DateDiff("d", A & "-1-1", getjq(Val(A), Val(i)))
   Cells(j + 2, 4).Value = i & F(i) & " " & getjq(Val(A), Val(i))
   
   If i = 2 Then
      B = Left(Right(Cells(j + 2, 3).Value, 3), 1)
      For k = 0 To 9
        If T(k) = B Then
           '戊=4
           If k < 4 Then
              Cells(j + 2 + 4 - k + 40, 5).Value = "春社"
           Else
              Cells(j + 2 + 14 - k + 40, 5).Value = "春社"
           End If
           Exit For
        End If
      Next
      
   ElseIf i = 8 Then
      Cells(j + 2, 6).Value = "立夏节"
      
   ElseIf i = 10 Then
      B = Left(Right(Cells(j + 2, 3).Value, 3), 1)
      For k = 0 To 9
        If T(k) = B Then
           '丙=3
           If k <= 2 Then
              Cells(j + 2 + 2 - k, 5).Value = "入梅"
           Else
              Cells(j + 2 + 12 - k, 5).Value = "入梅"
           End If
           Exit For
        End If
      Next
      
   ElseIf i = 11 Then
      For k = 0 To 72 Step 9
         Cells(j + 2 + k, 5).Value = "夏" & N(k / 9) & "九"
      Next
      '三时：夏至后的半个月
      Cells(j + 2 + 1, 4).Value = "上时（头时）"
      Cells(j + 2 + 4, 4).Value = "中时（二时）"
      Cells(j + 2 + 9, 4).Value = "末时（三时）"
      '三伏
      B = Left(Right(Cells(j + 2, 3).Value, 3), 1)
      For k = 0 To 9
        If T(k) = B Then
           '庚=6
           If k < 6 Then
              Cells(j + 2 + 6 - k + 20, 4).Value = "初伏"
              Cells(j + 2 + 6 - k + 30, 4).Value = "中伏"
           Else
              Cells(j + 2 + 16 - k + 20, 4).Value = "初伏"
              Cells(j + 2 + 16 - k + 30, 4).Value = "中伏"
           End If
           Exit For
        End If
      Next

   ElseIf i = 12 Then
      B = Left(Right(Cells(j + 2, 3).Value, 2), 1)
      For k = 0 To 9
        If D(k) = B Then
           '地支 未=7
           If k <= 7 Then
              Cells(j + 2 + 7 - k, 5).Value = "出梅"
           Else
              Cells(j + 2 + 19 - k, 5).Value = "出梅"
           End If
           Exit For
        End If
      Next
   ElseIf i = 14 Then
      B = Left(Right(Cells(j + 2, 3).Value, 3), 1)
      For k = 0 To 9
        If T(k) = B Then
           '庚=6
           If k < 6 Then
              Cells(j + 2 + 6 - k, 4).Value = "末伏"
           Else
              Cells(j + 2 + 16 - k, 4).Value = "末伏"
           End If
           Exit For
        End If
      Next
      For k = 0 To 9
        If T(k) = B Then
           '戊=4
           If k < 4 Then
              Cells(j + 2 + 4 - k + 40, 5).Value = "秋社"
           Else
              Cells(j + 2 + 14 - k + 40, 5).Value = "秋社"
           End If
           Exit For
        End If
      Next
   ElseIf i = 23 Then
      Cells(j + 2, 6).Value = "冬节"
      j2 = DateDiff("d", A & "-1-1", getjq(Val(A - 1), Val(i)))
      For k = 0 To 72 Step 9
         If j + k >= 0 And j + k < 365 Then Cells(j + 2 + k, 5).Value = "冬" & N(k / 9) & "九"
         If j2 + k >= 0 And j2 + k < 365 Then Cells(j2 + 2 + k, 5).Value = "冬" & N(k / 9) & "九"
      Next
      Cells(j2 + 2 + 103, 6).Value = "寒食节"
      Cells(j2 + 2 + 104, 6).Value = "清明节"
   End If
Next

With Worksheets("农历节日")
.Cells(1, 5).Value = A
For i = 2 To .[a2].End(4).Row
    j = DateDiff("d", A & "-1-1", .Cells(i, 6).Value)
    If j >= 0 And j < 365 Then Cells(j + 2, 6).Value = .Cells(i, 2).Value
    k = DateDiff("d", A & "-1-1", .Cells(i, 5).Value)
    If k >= 0 And k < 365 Then Cells(k + 2, 6).Value = .Cells(i, 2).Value
Next
End With

With Worksheets("阳历节日")
.Cells(1, 8).Value = A
For i = 2 To .[a2].End(4).Row
    j = DateDiff("d", A & "-1-1", .Cells(i, 8).Value)
    If j >= 0 Then Cells(j + 2, 7).Value = .Cells(i, 3).Value
Next
End With

End Sub

hcm19522

A4:G9=IF(MONTH(DATE($P$1,$C$2,(ROW(A1)-1)*7+COLUMN(A1)-WEEKDAY(DATE($P$1,$C$2,1),2)+1))=$C$2,(ROW(A1)-1)*7+COLUMN(A1)-WEEKDAY(DATE($P$1,$C$2,1),2)+1,"")

複製A4到每月第一格 如 I4,Q4,Y4,A13,I13….A22,I22….後改程式 二個ROW與二個COLUMN裡改A1 ;
四個$C$2改對應月份格名稱 如$K$2,$C$11,$S$20,$AA$20…. ;另月份格式化:自訂 -->0 月 ;輸入 P1西元年

lsc900707

zopey 发表于 2018-2-8 15:32
Private Sub CommandButton1_Click()
Dim T, D, N, F
Rows("2:65535").ClearContents

鼓励分享，支持原创，点赞！

lobmna

支持原创，点赞

lobmna

http://club.excelhome.net/thread-1281548-1-1.html
这位高手做出来的产品，用着不错，非常感谢之前的出手相助，今天回访，互相分享一下优秀作品，

附件是大神的作品，分享出来，大家互相交流学习，共同提高。

lobmna

http://club.excelhome.net/thread-1281548-1-1.html
这位高手做出来的产品，用着不错，非常感谢之前的出手相助，今天回访，互相分享一下优秀作品，

附件是大神的作品，分享出来，大家互相交流学习，共同提高。

上一楼的小绿色软件是1900-2199年的，本楼是原作者新的更新，是真正的万年历了1900-9999年的，

zopey

lobmna 发表于 2018-3-6 12:52
http://club.excelhome.net/thread-1281548-1-1.html
这位高手做出来的产品，用着不错，非常感谢之前的 ...

期待你的作品

lobmna

zopey 发表于 2018-3-6 13:42
期待你的作品

首先申明一下，上二楼分享的作品不是本人的作品，本人只是纯分享转发而以，原创作者为不见枝叶。

shiyiii

谢谢楼主分享精品内容，学习学习