VBA法自动返回当前周次

一指禅62

1. Option Explicit
   
2. 
   
3. Sub 获取当前日所处学期周次()
   
4.     Dim rq1 As Date, rq2 As Date, rq3 As Date, rq4 As Date
   
5.     Dim y As Integer, w As Integer
   
6.     If Year(Date) > Year(Lunar(Format(Date, "yyyy-m-d"))) Then y = 1
   
7.     rq1 = Format(solar(Year(Date) - y & "-1-12"), "yyyy-m-d")  '下学期正月十二开学
   
8.     rq2 = DateSerial(Year(Date) - y, 7, 1)                     '下学期7月1日结束
   
9.     rq3 = DateSerial(Year(Date) - y, 9, 1)                     '上学期9月1日开学
   
10.     rq4 = Format(solar(Year(Date) - y & "-12-15"), "yyyy-m-d") '上学期腊月十五结束
    
11.     Select Case Date
    
12.         Case rq1 To rq2
    
13.             w = WorksheetFunction.RoundUp(DateDiff("d", rq1, Date) / 7, 0) + 1
    
14.             MsgBox "今天是：下学期第 " & w & " 周，" & Format(Date, "aaaa")
    
15.         Case rq3 To rq4
    
16.             w = WorksheetFunction.RoundUp(DateDiff("d", rq3, Date) / 7, 0) + 1
    
17.             MsgBox "今天是：上学期第 " & w & " 周，" & Format(Date, "aaaa")
    
18.         Case Else
    
19.             MsgBox "放假期间"
    
20.     End Select
    
21. End Sub

复制代码

一指禅62

附件


VBA求周次.zip (24.9 KB, 下载次数: 78)

2016-1-17 14:22 上传

点击文件名下载附件

weiyingde

比我的代码更简洁更实用，很好，技高一筹，令人佩服！！

weiyingde

这样VBA代码就摆脱了对工作表辅助单元格的依赖了，很好，学习了。

一指禅62

weiyingde 发表于 2016-1-17 14:42
比我的代码更简洁更实用，很好，技高一筹，令人佩服！！

我的思路是：

所有日期必须转换为公历，以计算当日与开学日期相差的天数；

先判断农历年份与公历年份的异同，从而确定当前的年份并生成四个节点（日期）；

再把开学第一天所在的周作为第一周，计算出周数。

weiyingde

是的，看得出，很巧妙。正应一句话：想法对一切都对！！

weiyingde

我的思路是：
分为三个节点：9月1到年底；元旦到腊月15；正月15到7月1日；
但我是阳历和阳历日相比较；阴历日和阴历日相比较，确定起始点；
因为你的比较在同一个层面上，所以，思路更清晰，代码也更简洁。
以后多向你学习。

weiyingde

将上面的研讨的结果，奉献给大家，并藉此对一指禅62等E有提供的版主表示感谢！！

一指禅62

weiyingde 发表于 2016-1-17 10:24
一指禅62友，format函数得出的结果真是很怪，讨教一下其特点。到底是string，还是Date呢？如果不是的话， ...

查了点资料，是这么说的：变体型（Variant）数据是VBA中最灵活的数据类型，可存储各种类型的数据，包括各种标准数据类型和特定值（Empty、Null、Error）。VBA自动识别保存数据的类型。
我理解，在没有指定其数据类型的情况下，Format(Year(Date) & "/5/1", "yyyy-mm-dd") 函数返回的是字符串型，DateSerial(Year(Now()), 5, 1) 函数返回的是日期型。

但是，一旦指定数据类型，它就会返回相应的类型。

如下例：

1. Sub 测试()
   
2.     Dim t As String
   
3.     t = DateSerial(Year(Now()), 5, 1)
   
4.     MsgBox TypeName(t)
   
5. End Sub

复制代码

weiyingde

format可真行呀，简直就是VBA函数中的变色龙，有意思，有意思！！