[求助]如何制作自动提示上交报表？再次出现新问题出现，求助各位版主高手中......

secowu

这是自您晓月清风回复后（周五吧）再次新出现的问题：

麻烦看看下面的问题：

经过考虑，大概有下面情况：

If Day(Now) - 1 = 0 And Format(Worksheets("数值").Range("c2"), "yyyy-mm") = Format(Now, "yyyy-mm") Then

1.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A=0月初第一天时，提示打开正确的报表

2.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，

   分类：周一或非周一。执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的

3.报表里的标记日期里的月份M1<>当前系统日期里的月份时M2，且M1+1=M2时，并且A=0月初第一天,执行报表复制

  分类：周一或非周一。执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的

4.报表里的标记日期里的月份M1<>当前系统日期里的月份时M2，且M1+1<>M2时，并且A<>0非月初第一天,提示打开

5.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，执行报表复制

   分类：周一或非周一。 执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的

如何把这些条件加入下面的代码里呢？我加了点，测试出现了一些错误，解决不了。谢谢

Private Sub Workbook_open()

Dim a As String

Dim b As String

Dim c As String ' 创建一个临时变量，以防出现生成的文件名为0号

Dim RptName1 As String

Dim RptName2 As String

Dim mypath As String

Dim Done As String '生成上交报表的日期与时间

Dim MyToday As String

Dim Msg, Style, Title, Help, Ctxt, Response, MyString

RptName1 = Month(Now) & "月" & Day(Now) - 1 & "号"

RptName2 = Month(Now) & "月" & Day(Now) - 2 & "号"

Done = Now()

MyToday = Month(Now()) & "月" & Day(Now()) & "号" '将生成日期标记于生成的报表名称

Msg = "要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢"

Style = vbYesNo + vbInformation + vbDefaultButton1

Title = "请在生成后检查！！！谢谢"

If Day(Now) - 1 = 0 And Format(Worksheets("数值").Range("c2"), "yyyy-mm") = Format(Now, "yyyy-mm") Then

'检查打开的报表日期与系统日期相同，且为月初的第一天，则提示打开正确的报表

   MsgBox "本月是月初的第一天，请打开正确的报表并上交！谢谢"

   Application.Workbooks.Open (Application.GetOpenFilename)

  '如果点取消的话，会出现无法找到文件FALSE的提示，并导致宏出错，如何添加出错机制，允许取消？

Else

If Day(Now) - 1 = 0 And Format(Worksheets("数值").Range("c2"), "yyyy-mm") > Format(Now, "yyyy-mm") Then

'检查打开的报表日期与系统日期相同，且为月初的第一天，则提示打开正确的报表

   MsgBox "本月是月初的第一天，打开的报表月份与系统月份不一致，请打开正确的报表并上交！谢谢"

   Application.Workbooks.Open (Application.GetOpenFilename)

  '如果点取消的话，会出现无法找到文件FALSE的提示，并导致宏出错，如何添加出错机制，允许取消？

Else

Response = MsgBox(Msg, Style, Title, Help, Ctxt)

If Response = vbYes Then

    MyString = "Yes"

    a = Day(Now) - 1 '定义出需要复制的工作表名

    mypath = ThisWorkbook.Path ''获得当前文件存放的位置

If a = 0 And Format(Worksheets("数值").Range("c2"), "yyyy") = Format(Now, "mm") And Format(Worksheets("数值").Range("c2") - 1, "mm") = Format(Now, "mm") Then

'即判断当前日期是否为月初第一天，并且打开的工作表标记月份+1是否与系统月份相同。如果是则提醒打开上个月的报表

    a = Day(DateSerial(Year(Now), Month(Now), 0))

    c = Month(Now) - 1 '创建一个临时变量，以防出现生成的文件名为0号

     Sheets(Array(a, "黄小姐")).Copy

    ActiveWorkbook.SaveAs Filename:= _

        mypath &amp

晓月清风

刚刚又进行了一次测试，发现RIGHT（PRTDATE，1）只返回一位数值，在2005-11-1时，就不能正确返回上个月的月份为10，所以以下红色代码ElseIf a = 0 And RPTDate < SYSDate And Right(RPTDate, 1) + 1 = Month(Now) Then

        a = Day(DateSerial(Year(Now), Month(Now), 0))

        x = Weekday(DateSerial(Year(Now), Right(RPTDate, 1), a))

        If x = 2 Then MsgBox "上个月最后一天是星期一，请提交星期天和星期一的两张报表！"

        MsgBox "报表日期是:" & RPTDate & ".系统日期是:" & Date & ".请手动复制并提交上个月最后一天的报表！"

应改为：ElseIf a = 0 And Month(Now) = Month(Worksheets("数值").[c2]) + 1 Then

        a = Day(DateSerial(Year(Now), Month(Now), 0))

        x = Weekday(DateSerial(Year(Now), Month(Worksheets("数值").[c2]), a))

        If x = 2 Then

        MsgBox "上个月最后一天是星期一，请提交星期天和星期一的两张报表！"

        Else

        MsgBox "报表日期是:" & RPTDate & ".系统日期是:" & Date & ".请手动复制并提交上个月最后一天的报表！"

        End If

secowu

这是最后修改的代码：非常感谢晓月清风Private Sub Workbook_open()

Dim a As String, b As String

Dim RptName1 As String, RptName2 As String, mypath As String

Dim MyToday As String, Msg As String, Title As String

Dim RPTDate, SYSDate As StringRPTDate = Format(Worksheets("1").Range("B1"), "yyyy-mm") '得出报表里的日期标识

SYSDate = Format(Now, "yyyy-mm") '得出系统日期的格式

a = Day(Now) - 1

Done = Now()

MyToday = Month(Now()) & "月" & Day(Now()) & "号" '将生成日期标记于生成的报表名称

Msg = "要现在上交报表吗？当前系统日期是：" & Date & "。打开的报表日期为：" & RPTDate

Title = "本检测程序基于PC系统时间，请检查您的电脑系统时间是否正确！"If a <> 0 And RPTDate = SYSDate Then

    If MsgBox(Msg, vbYesNo, Title) = vbYes Then

       mypath = ThisWorkbook.Path ''获得当前文件存放的位置

       RptName1 = Month(Now) & "月" & Day(Now) - 1 & "号"

       RptName2 = Month(Now) & "月" & Day(Now) - 2 & "号"

      

       If Weekday(Now) = 2 Then '判断是否为星期一

          b = a - 1

          Sheets(a).Activate

          Sheets(Array(a, b, "黄小姐")).Copy

          ActiveWorkbook.SaveAs Filename:=mypath & "\" & RptName1 & "和" & RptName2 & "的生产报表(上交)：创建于" & MyToday & ".xls"

          MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的与" & b & "号的，请注意检查！！！！完成于" & Done

       Else

          Sheets(Array(a, "黄小姐")).Copy

          ActiveWorkbook.SaveAs Filename:=mypath & "\" & RptName1 & "的生产报表(上交)：创建于" & MyToday & ".xls", FileFormat:=xlNormal

          MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的，请注意检查！！！！完成于" & Done

       End If

    Else

        Sheets(a).Activate

    End If

      

ElseIf a <> 0 And RPTDate <> SYSDate Then MsgBox "报表日期是：" & RPTDate & ".系统日期是：" & Date & "。且当前不是月初，可能系统时间错误或是打开报表错误，请检查。"ElseIf a = 0 And RPTDate = SYSDate Then MsgBox "报表日期是:" & RPTDate & ".系统日期是:" & Date & "。现在是月初第一天，请打开" & Month(Now) - 1 & "月的报表"ElseIf a = 0 And RPTDate < SYSDate And Right(RPTDate, 1) + 1 = Month(Now) Then

        a = Day(DateSerial(Year(Now), Month(Now), 0))

        x = Weekday(DateSerial(Year(Now), Right(RPTDate, 1), a))

        If x = 2 Then MsgBox "上个月最后一天是星期一，请提交星期天和星期一的两张报表！"

        MsgBox "报表日期是:" & RPTDate & ".系统日期是:" & Date & ".请手动复制并提交上个月最后一天的报表！"

        

Else

MsgBox "报表日期是:" & RPTDate & ".系统日期是:" & Date & "可能系统时间错误或是打开报表错误，请检查。"

     

End IfEnd Sub

secowu

刚测试完毕，发现完全正确真的非常感谢而且这样，代码也精简了许多，看了一目了然厉害，还请多多指教再次感谢

secowu

非常感谢，我这就去测试下

晓月清风

x = Weekday(DateSerial(Year(Now), Right(RPTDate, 1) + 1, a))

这句应该改为：x=Weekday(DateSerial(Year(Now), Right(RPTDate, 1) , a))，再加一的话就是判断本月最后一天是否为星期一了。我测试了一下，就发现了这个问题

晓月清风

测试一下以下的代码，看看还有什么问题：

Private Sub Workbook_open()

Dim a As String, b As String

Dim RptName1 As String, RptName2 As String, mypath As String

Dim MyToday As String, Msg As String, Title As String

Dim RPTDate, SYSDate As StringRPTDate = Format(Worksheets("数值").Range("c2"), "yyyy-mm") '得出报表里的日期标识

SYSDate = Format(Now, "yyyy-mm") '得出系统日期的格式

a = Day(Now) - 1

Done = Now()

MyToday = Month(Now()) & "月" & Day(Now()) & "号" '将生成日期标记于生成的报表名称

Msg = "要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢"

Title = "请在生成后检查！！！谢谢"If a <> 0 And RPTDate = SYSDate Then

    If MsgBox(Msg, vbYesNo, Title) = vbYes Then

       mypath = ThisWorkbook.Path ''获得当前文件存放的位置

       RptName1 = Month(Now) & "月" & Day(Now) - 1 & "号"

       RptName2 = Month(Now) & "月" & Day(Now) - 2 & "号"

      

       If Weekday(Now) = 2 Then '判断是否为星期一

          b = a - 1

          'Sheets(a).Activate

          Sheets(Array(a, b, "黄小姐")).Copy

          ActiveWorkbook.SaveAs Filename:=mypath & "\" & RptName1 & "和" & RptName2 & "的生产报表(上交)：创建于" & MyToday & ".xls"

          MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的与" & b & "号的，请注意检查！！！！完成于" & Done

       Else

          Sheets(Array(a, "黄小姐")).Copy

          ActiveWorkbook.SaveAs Filename:=mypath & "\" & RptName1 & "的生产报表(上交)：创建于" & MyToday & ".xls", FileFormat:=xlNormal

          MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的，请注意检查！！！！完成于" & Done

       End If

    Else

        Sheets("黄小姐").Activate

    End If

      

ElseIf a <> 0 And RPTDate <> SYSDate Then MsgBox "当前不是月初，但系统时间错误或是报表错误"ElseIf a = 0 And RPTDate = SYSDate Then MsgBox "现在是月初第一天，请打开" & Month(Now) - 1 & "月的报表"ElseIf a = 0 And RPTDate < SYSDate And Right(RPTDate, 1) + 1 = Month(Now) Then

        a = Day(DateSerial(Year(Now), Month(Now), 0))

        x = Weekday(DateSerial(Year(Now), Right(RPTDate, 1) + 1, a))

        If x = 2 Then MsgBox "上个月最后一天是星期一，请提交星期天和星期一的两张报表！"

        MsgBox "请手动复制并提交上个月最后一天的报表！"

        

Else

MsgBox "系统时间错误或是报表错误"

     

End IfEnd Sub

secowu

以下是引用晓月清风在2005-7-5 8:20:00的发言：

根据你的五点要求，是要求当A=0，即在月初时，自动打开正确的报表后，又让EXCEL自动在新打开的报表文件中提交正确的报表，而不是原来的手动复制了！

看来这样会形成不断循环或是代码不执行。所以，我想还是提示手动复制就行了。

并且如果上个月最后一天刚好也是星期一时，则要复制两张报表，这就必须再增加判断上个月最后一天是否为星期一。有点不好办！另外，当你调用“打开”对话框，并打开一个具有相同代码的报表文件（2005-06.xls)，就会运行WORKBOOK_OPEN（），也就是一打开就提示是否提交报表，按"是"则提交相应的报表。如果今天是月初，则又提示打开新的文件报表。而且在原报表文件（2005-07.xls）打开新报表文件后，接下来的代码都将不会被执行，因为焦点已转移到新的工作簿文件中的宏。

现在的问题是：加入月份判断

精简下：

先用RPTDate，SYSDate

Dim RPTDate,SYSDate as String

RPTDate=Format(Worksheets("数值").Range("c2"), "yyyy-mm") '得出报表里的日期标识

SYSDate= Format(Now, "yyyy-mm") '得出系统日期的格式

然后再进行判断：

如果相同：

则执行下面的代码：当周一进，复制前两天的，如果是月初一号，则提醒打开正确的报表，否则复制前一天的

如果不同：

当RPTDate>SYSDate时，或是

当RPTDate<SYSDate时，并且Right(RPTDate,1)+1<>Right(SYSDate,1)

提醒系统时间错误或是报表错误，并调用打开对话框 不调用打开对话框了

当RPTDate<SYSDate时，并且Right(RPTDate,1)+1=Right(SYSDate,1)

就是为系统日期前一个月份时，这种情况出现在月初第一天时，执行复制

但仍旧有两种情况，可能是星期一，或不是星期一

提醒系统时间错误或是报表错误，并调用打开对话框 不调用打开对话框了



现在应该是包括了所有的情况了吧？

那么怎么写代码呢？

谢谢

条件一多，我头就大了～_～

[此贴子已经被作者于2005-7-5 8:47:23编辑过]

晓月清风

根据你的五点要求，是要求当A=0，即在月初时，自动打开正确的报表后，又让EXCEL自动在新打开的报表文件中提交正确的报表，而不是原来的手动复制了！并且如果上个月最后一天刚好也是星期一时，则要复制两张报表，这就必须再增加判断上个月最后一天是否为星期一。有点不好办！另外，当你调用“打开”对话框，并打开一个具有相同代码的报表文件（2005-06.xls)，就会运行WORKBOOK_OPEN（），也就是一打开就提示是否提交报表，按"是"则提交相应的报表。如果今天是月初，则又提示打开新的文件报表。而且在原报表文件（2005-07.xls）打开新报表文件后，接下来的代码都将不会被执行，因为焦点已转移到新的工作簿文件中的宏。

[此贴子已经被作者于2005-7-5 8:35:29编辑过]

晓月清风

以下是引用secowu在2005-7-4 16:41:00的发言：

If Weekday(Now) = 2 Then '判断是否为星期一

    b = a - 1

    Sheets(Array(a, b, "黄小姐")).Copy

    '这里出现下标越界？怎么解决呢？

'在EXCEL2000中，并不会出现“下标越界”

我用MSG进行测试了，原来是a值为0，所以出错了。

没错，根据你的代码，到这句时，A=0，我测试时已将If Weekday(Now) = 2 Then 改为ElseIf Weekday(Now) = 2 Then ,所以没发现错误。