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

secowu

我是后来这样想了一个办法,但没写出可行的代码来:因为,每个报表的工作表里都有一个单元格是记录日期的.所以,我就想,可以先获得那个单元格的内容,得到像这样的字符:2005-07-03getcell("1"!,$A$2)if format(now(),"yyyy-mm")=getcell("1"!,$A$2) And a <> 0 And Weekday(Now) <> 2 Then

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

不知这样行不行呀?谢谢然后,就可以判断,打开的工作簿是哪个月份的.这样我就少写了个自定义函数了.这样会不会更简洁呢?

secowu

我还是很喜欢这个版,清风明月版主很令我感动呀.

secowu

非常感谢晓月清风经过测试，当打开的文件名中与系统的日期前7位不同时，会出现不作为的情况。

secowu

我经过测试了，这个可以引用单元格的值，然后进行判断打开的报表与系统的时间问题Private Sub Workbook_Open()

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

MsgBox "系统时间与打开的工作表名称一致", vbInformation, "提示"

Else

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

End If

End Sub

secowu

麻烦看看下面的问题：经过考虑，大概有下面情况：If Day(Now) - 1 = 0 And Format(Worksheets("数值").Range("c2"), "yyyy-mm") = Format(Now, "yyyy-mm") Then1.报表里的标记日期里的月份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 & "\" & c & "月" & a & "号" & "的生产报表(上交)：创建于" & MyToday & ".xls", FileFormat:=xlNormal _

晓月清风

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

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



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

感觉好混乱!!!!

secowu

我也感觉好乱了。条件一多，就麻烦了。精简下：先用RPTDate，SYSDateDim RPTDate,SYSDate as StringRPTDate=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)就是为系统日期前一个月份时，这种情况出现在月初第一天时，执行复制但仍旧有两种情况，可能是星期一，或不是星期一提醒系统时间错误或是报表错误，并调用打开对话框 现在应该是包括了所有的情况了吧？那么怎么写代码呢？谢谢

晓月清风

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



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

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

    b = a - 1

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

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

'在EXCEL2000中，并不会出现“下标越界”我用MSG进行测试了，原来是a值为0，所以出错了。

晓月清风

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