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

晓月清风

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

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

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编辑过]

晓月清风

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

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

晓月清风

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

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

secowu

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

secowu

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

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

晓月清风

刚刚又进行了一次测试，发现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