公司的工厂日历的模块代码，进行修改规整

yanwei82123300

下面是我公司的工厂日历的模块代码：它是有规律的每一个P几都是开始日期和结束日期减
请问有没有办法写一段万年历是的代码，免去每次都需要更改里面的日期的代码。
谢谢
Fisher2010年工厂日历
Function GetP(a As Date) As String

    Dim Re As String
    If a >= CDate("2009-10-1") And a <= CDate("2009-10-23") Then
         Re = "2010_P1"
    ElseIf a >= CDate("2009-10-24") And a <= CDate("2009-11-20") Then
        Re = "2010_P2"
    ElseIf a >= CDate("2009-11-21") And a <= CDate("2009-12-25") Then
        Re = "2010_P3"
    ElseIf a >= CDate("2009-12-26") And a <= CDate("2010-01-22") Then
        Re = "2010_P4"
    ElseIf a >= CDate("2010-01-23") And a <= CDate("2010-02-19") Then
        Re = "2010_P5"
    ElseIf a >= CDate("2010-02-20") And a <= CDate("2010-03-26") Then
        Re = "2010_P6"
    ElseIf a >= CDate("2010-03-27") And a <= CDate("2010-04-23") Then
        Re = "2010_P7"
    ElseIf a >= CDate("2010-04-24") And a <= CDate("2010-05-21") Then
        Re = "2010_P8"
    ElseIf a >= CDate("2010-05-22") And a <= CDate("2010-06-25") Then
        Re = "2010_P9"
    ElseIf a >= CDate("2010-06-26") And a <= CDate("2010-07-23") Then
        Re = "2010_P10"
    ElseIf a >= CDate("2010-07-24") And a <= CDate("2010-08-20") Then
        Re = "2010_P11"
    ElseIf a >= CDate("2010-08-21") And a <= CDate("2010-09-30") Then
        Re = "2010_P12"
    Else
    End If
   
    GetP = Re

End Function


Fisher2011年工厂日历

Function GetP(A As Date) As String

    Dim Re As String
    If A >= CDate("2010-10-1") And A <= CDate("2010-10-22") Then
         Re = "2011_P1"
    ElseIf A >= CDate("2010-10-23") And A <= CDate("2010-11-19") Then
        Re = "2011_P2"
    ElseIf A >= CDate("2010-11-20") And A <= CDate("2010-12-24") Then
        Re = "2011_P3"
    ElseIf A >= CDate("2010-12-25") And A <= CDate("2011-01-21") Then
        Re = "2011_P4"
    ElseIf A >= CDate("2011-01-22") And A <= CDate("2011-02-18") Then
        Re = "2011_P5"
    ElseIf A >= CDate("2011-02-19") And A <= CDate("2011-03-25") Then
        Re = "2011_P6"
    ElseIf A >= CDate("2011-03-26") And A <= CDate("2011-04-22") Then
        Re = "2011_P7"
    ElseIf A >= CDate("2011-04-23") And A <= CDate("2011-05-20") Then
        Re = "2011_P8"
    ElseIf A >= CDate("2011-05-21") And A <= CDate("2011-06-24") Then
        Re = "2011_P9"
    ElseIf A >= CDate("2011-06-25") And A <= CDate("2011-07-22") Then
        Re = "2011_P10"
    ElseIf A >= CDate("2011-07-23") And A <= CDate("2011-08-19") Then
        Re = "2011_P11"
    ElseIf A >= CDate("2011-08-20") And A <= CDate("2011-09-30") Then
        Re = "2011_P12"
    Else
    End If
   
    GetP = Re

End Function

Fisher2012年工厂日历

Function GetP(A As Date) As String

    Dim Re As String
    If A >= CDate("2011-10-1") And A <= CDate("2011-10-21") Then
         Re = "2012_P1"
    ElseIf A >= CDate("2011-10-22") And A <= CDate("2011-11-18") Then
        Re = "2012_P2"
    ElseIf A >= CDate("2011-11-19") And A <= CDate("2011-12-23") Then
        Re = "2012_P3"
    ElseIf A >= CDate("2010-12-24") And A <= CDate("2012-01-20") Then
        Re = "2012_P4"
    ElseIf A >= CDate("2012-01-21") And A <= CDate("2012-02-17") Then
        Re = "2012_P5"
    ElseIf A >= CDate("2012-02-18") And A <= CDate("2012-03-24") Then
        Re = "2012_P6"
    ElseIf A >= CDate("2012-03-25") And A <= CDate("2012-04-21") Then
        Re = "2012_P7"
    ElseIf A >= CDate("2012-04-22") And A <= CDate("2012-05-19") Then
        Re = "2012_P8"
    ElseIf A >= CDate("2012-05-20") And A <= CDate("2012-06-23") Then
        Re = "2012_P9"
    ElseIf A >= CDate("2012-06-24") And A <= CDate("2012-07-21") Then
        Re = "2012_P10"
    ElseIf A >= CDate("2012-07-22") And A <= CDate("2012-08-18") Then
        Re = "2012_P11"
    ElseIf A >= CDate("2012-08-19") And A <= CDate("2012-09-30") Then
        Re = "2012_P12"
    Else
    End If
   
    GetP = Re

End Function

yanwei82123300

非常谢谢todaynew 帮助！

todaynew

todaynew 老师我要提取日期的目的是将客户订单的需求日期与这个日期做链接目的是：1、看订单落在哪一个月？ ...
yanwei82123300 发表于 2010-10-12 08:12

最后的示例中已经给你写了两个函数，其中mnth函数就是用来返回相应数据的。

Function Calendar(Myyear As Long) As String
'功能：每季度按445周的的工厂日历
'参数：Myyear--财政年度
'示例：Me.日历.RowSource = "月度;首日;末日;" & Calendar(Me.年度.Value)
Dim mydate As Date
Dim str As String
Dim i As Long, j As Long, m
mydate = DateSerial(Myyear - 1, 10, 1)
str = str & 1 & ";" & mydate & ";"
If Weekday(mydate, vbMonday) <> 6 Then
    mydate = DateAdd("d", 21, mydate)
    For j = 1 To 7
        If Weekday(mydate, vbMonday) = 5 Then
                Exit For
        End If
        mydate = DateAdd("d", 1, mydate)
    Next
Else
    mydate = DateAdd("d", 20, mydate)
End If
str = str & mydate & ";"
m = 0
For i = 1 To 4
    For j = 1 To 3
        m = m + 1
        If m = 12 Then Exit For
        If m <> 1 Then
            str = str & m & ";" & DateAdd("d", 1, mydate) & ";"
            If j <> 3 Then
                mydate = DateAdd("d", 28, mydate)
            Else
                mydate = DateAdd("d", 35, mydate)
            End If
            str = str & mydate & ";"
        End If
    Next
    If m = 12 Then Exit For
Next
str = str & m & ";" & DateAdd("d", 1, mydate) & ";" & DateSerial(Myyear, 9, 30)
Calendar = str
End Function

Function mnth(mydate As Date) As Variant
'功能：按日历日期返回财政日历数组
'参数：mydate--日历日期
'示例：
'
'select *,mnth(订单日期)(0) as 财政年,mnth(订单日期)(1) as 财政月,mnth(订单日期)(4) as 周 from 订单表
Dim str As String
Dim myMonth As Long
Dim A
Dim B(5)
Dim date0 As Date, date1 As Date
Dim i As Long
If Month(mydate) >= 10 And Month(mydate) <= 12 Then
    str = Calendar(Year(mydate) + 1)
    B(0) = Year(mydate) + 1
Else
    str = Calendar(Year(mydate))
    B(0) = Year(mydate)
End If
A = Split(str, ";")
For i = 0 To UBound(A, 1) Step 3
    myMonth = A(i)
    date0 = CDate(A(i + 1))
    date1 = CDate(A(i + 2))
    If CDate(mydate) >= date0 And CDate(mydate) <= date1 Then
        B(2) = date0: B(3) = date1
        B(4) = DateDiff("ww", date0, mydate)
        Exit For
    End If
Next
B(1) = myMonth
mnth = B
End Function

yanwei82123300

todaynew 老师我要提取日期的目的是将客户订单的需求日期与这个日期做链接目的是：1、看订单落在哪一个月？，哪一周？来分析订单的完成情况：为何没有按时完成？是何原因？
2、看物料的采购日期落在哪一个月？，哪一周？是否有延迟采购情况？采购的周期是否充足（LT)?
谢谢

todaynew

todaynew 老师：“请问老师能否将范例中数据提取出来”我的意思是输入：2011 就可以将2011年度的日历全部数 ...
yanwei82123300 发表于 2010-10-11 16:17

获得全部日历不困难，只是365次循环而已，问题在于这365个日期看他无益，瞅他没用。
因为你只需要一个具体的日历日期属于哪个财政年度和财政月度就可以了。所谓全部日期可以通过图示来查看，也可以从日历中选取某个日期来获得其所属的财政年度和财政月度。比如：





这样的一种处理思路就是所谓的黑箱理论，也就是说知道输入值得到输出值，至于在什么范围内计算和如何计算不必去关心。

yanwei82123300

todaynew 老师：“请问老师能否将范例中数据提取出来”我的意思是输入：2011 就可以将2011年度的日历全部数据提取出来！谢谢

todaynew

todaynew 老师谢谢帮助，您在11楼放置实例第三个日历
请问老师能否将范例中数据提取出来。谢谢！
yanwei82123300 发表于 2010-10-11 14:36

11楼的第三例与15楼的示例算法一样，具体运用大体可以如下：





Function Calendar(Myyear As Long) As String
'功能：每季度按445周的的工厂日历
'参数：Myyear--财政年度
'示例：Me.日历.RowSource = "月度;首日;末日;" & Calendar(Me.年度.Value)
Dim mydate As Date
Dim str As String
Dim i As Long, j As Long, m
mydate = DateSerial(Myyear - 1, 10, 1)
str = str & 1 & ";" & mydate & ";"
If Weekday(mydate, vbMonday) <> 6 Then
    mydate = DateAdd("d", 21, mydate)
    For j = 1 To 7
        If Weekday(mydate, vbMonday) = 5 Then
                Exit For
        End If
        mydate = DateAdd("d", 1, mydate)
    Next
Else
    mydate = DateAdd("d", 20, mydate)
End If
str = str & mydate & ";"
m = 0
For i = 1 To 4
    For j = 1 To 3
        m = m + 1
        If m = 12 Then Exit For
        If m <> 1 Then
            str = str & m & ";" & DateAdd("d", 1, mydate) & ";"
            If j <> 3 Then
                mydate = DateAdd("d", 28, mydate)
            Else
                mydate = DateAdd("d", 35, mydate)
            End If
            str = str & mydate & ";"
        End If
    Next
    If m = 12 Then Exit For
Next
str = str & m & ";" & DateAdd("d", 1, mydate) & ";" & DateSerial(Myyear, 9, 30)
Calendar = str
End Function

Function mnth(mydate As Date) As Variant
'功能：按日历日期返回财政日历数组
'参数：mydate--日历日期
'示例：
'Dim A
'If IsDate(Me.日历日期) = True Then
      'A=mnth(Me.日历日期.Value)
      'Me.财政年度.Value = A(0)
      'Me.财政月度.Value =A(1)
      'Me.首日.Value = A(2)
      'Me.末日.Value = A(3)
'Else
    'MsgBox "日历日期不能为空！"
'End If
Dim str As String
Dim myMonth As Long
Dim A
Dim B(4)
Dim date0 As Date, date1 As Date
Dim i As Long
If Month(mydate) >= 10 And Month(mydate) <= 12 Then
    str = Calendar(Year(mydate) + 1)
    B(0) = Year(mydate) + 1
Else
    str = Calendar(Year(mydate))
    B(0) = Year(mydate)
End If
A = Split(str, ";")
For i = 0 To UBound(A, 1) Step 3
    myMonth = A(i)
    date0 = CDate(A(i + 1))
    date1 = CDate(A(i + 2))
    If CDate(mydate) >= date0 And CDate(mydate) <= date1 Then
        B(2) = date0: B(3) = date1
        Exit For
    End If
Next
B(1) = myMonth
mnth = B
End Function

yanwei82123300

todaynew 老师谢谢帮助，您在11楼放置实例第三个日历
请问老师能否将范例中数据提取出来。谢谢！

todaynew

todaynew 老师我查看了日历基本上都是倒数第二个星期五。具体请看上面的图片
yanwei82123300 发表于 2010-10-11 08:20

你没看明白吧？呵呵。

我看的规律是每季度中各月的周数按照445分配。你看看这个万年历与你的实际数据之间是否吻合（注意你2012年度的后几个月的数据是错误的）。

我以为财务部门这样的分配周数是有意义的，因为其一是这样可以使得季度间的日历天数基本均衡；其二是财务报表是按季度出具的，季度的头两个月由于票据处理不及时，可能导致数据不准确，因此可以给头两个月分配较少的天数；其三是季度的末月天数较多，有利于帐务处理在规定时间内完成。

aslxt

todaynew 老师我查看了日历基本上都是倒数第二个星期五。具体请看上面的图片
yanwei82123300 发表于 2010-10-11 08:20

楼主太不负责了，图中上面2行是倒数第二个周五，第三行是最后一个周五！
像这种不规律的划分，建议用表来记录划分期间的日期，然后用查询的方式确定某个日期是落在哪个【p】中，可以省略修改代码的麻烦，还可以把划分的权限交给那些有权指定某个月的截止日期的人，又不需要你修改代码。