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

晓月清风

啊，不好意思，昨天超忙，连上网的时间都没有，没能及时帮你解决问题。已根据你的要求改进代码如下，在EXCEL2000下通过测试；增加了一个自定义函数以返回文件名；宏函数我还没学，不会用。注意：以下代码是在文件名为2005-07生产报表.xls上运行的!!!在使用此代码时，必须先将文件名改为YYYY-MM????.xls格式

Private Sub Workbook_open()

Dim a As String, b As String, RptName1 As String, RptName2 As String

If MsgBox("要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢", vbOKCancel, "请在生成后检查！！！谢谢") = vbOK Then

'提示是否上交报表,当选择“是”时，执行下列代码：

   a = Day(Now) - 1

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

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

  

  If Mid(FileNameOnly(ThisWorkbook.FullName), 1, 7) = Format(Now, "yyyy-mm") And a <> 0 And Weekday(Now) <> 2 Then

  '判断此工作簿名称的前七位是否与当前日期“年-月”相符,且a不等于0，且不是星期一

     Sheets(a).Activate

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

     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & RptName1 & " 生产报表(上交).xls"

     MsgBox "提交的工作表为：" & a & "，黄小姐"

  ElseIf a = 0 Then

  '如果a=0，也就是月初，则提示

     MsgBox "当前日期为月初，请手动复制报表！谢谢！", vbInformation, "提示"

     Application.Workbooks.Open (Application.GetOpenFilename)

     '调用EXCEL的“打开”对话框，查找文件（即上个月的报表文件），并打开

  ElseIf Weekday(Now) = 2 Then

  '如果是星期一，则执行下列代码

      b = a - 1

      Sheets(a).Activate

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

      ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & RptName2 & "和" & RptName1 & "生产报表(上交).xls"

      MsgBox "提交的工作表为：" & a & "，" & b & "，黄小姐"

  End If

'结束判断文件名的前七位

  

Else

   Sheets("黄小姐").Activate

End If

End Sub



Private Function FileNameOnly(pname) As String

'增加这个自定义函数，可以返回路径pname的文件名

    Dim i As Integer, length As Integer, temp As String

    length = Len(pname)

    temp = ""

    For i = length To 1 Step -1

        If Mid(pname, i, 1) = Application.PathSeparator Then

            FileNameOnly = temp

            Exit Function

        End If

        temp = Mid(pname, i, 1) & temp

    Next i

    FileNameOnly = pname

End Function

晓月清风

第二点和第五点有何差别?

2.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，分类：周一或非周一。执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的



5.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，执行报表复制，分类：周一或非周一。 执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的

感觉好混乱!!!!

晓月清风

浏览了一下你的代码，大概明白你的意思了，但我现在没多少时间可以在网上，明天早上才有空,再提供完整代码供你参考。



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

Done = Now()

'不如不定义，在要用到的地方，使用NOW代替DONE即可

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

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

'这两个变量不能在开头赋值，否则如果今天是一号的话，RptName1=7月0号,RptName2=7月-1号

'应该在要使用到之前才赋值

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

    b = a - 1

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

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

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

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

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

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

   Application.Workbooks.Open (Application.GetOpenFilename)

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

'在Msgbox这句之前加上一句: On Error Goto ErrorHandler

'在Application这句下面加一句：ErrorHandler:

                                            Exit Sub

Format(Worksheets("数值").Range("c2"), "yyyy") = Format(Now, "mm")

'这两个值永远不会相等的

晓月清风

以下是引用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 ,所以没发现错误。

晓月清风

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

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

晓月清风

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

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))，再加一的话就是判断本月最后一天是否为星期一了。我测试了一下，就发现了这个问题

晓月清风

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