Office中国论坛/Access中国论坛
标题: [求助]如何制作自动提示上交报表？再次出现新问题出现，求助各位版主高手中...... [打印本页]
作者: secowu 时间: 2005-6-24 19:43
标题: [求助]如何制作自动提示上交报表？再次出现新问题出现，求助各位版主高手中......
这是自您晓月清风回复后（周五吧）再次新出现的问题：
麻烦看看下面的问题：
经过考虑，大概有下面情况：
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 &
作者: secowu 时间: 2005-6-24 19:44
变量是a不是L弄错了。不好意思
作者: 晓月清风 时间: 2005-6-25 16:08
ActiveWorkbook.SaveAs Filename:= _
"mypath & \上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
这句应改为：ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
另外，在SAVEAS一句中，如果这引起参数都不改变其默认值，也可以全部不写：Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
[此贴子已经被作者于2005-6-25 9:08:29编辑过]
作者: 晓月清风 时间: 2005-6-25 16:08
在VBA中，format函数似乎只能用于图表
作者: 晓月清风 时间: 2005-6-25 16:15
“L = Format(Now(), yyyy - mm) '求出系统当前的日期格式，为下面的寻找报表名字作准备”根据你的要求， 上面那一句可删除
作者: 晓月清风 时间: 2005-6-25 16:18
另外，之所以会引用错误是因为 Dim a As Integer和Sheets(a).Activate产生的，一个是工作表的编号，而你要引用的却是工作表的名称。
作者: 晓月清风 时间: 2005-6-25 16:20
修改后的代码如下：Private Sub Workbook_open()
Dim a As String '将A定义为字符串
Dim mypath As String
Dim myfile As String
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢"
Style = vbYesNo + vbInformation + vbDefaultButton1
Title = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置 Sheets(Array(a, "黄小姐")).Select
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Else
MyString = "No"
Sheets("黄小姐").Activate
End If
End Sub
作者: 晓月清风 时间: 2005-6-25 16:44
突然又想起代码中还存在着一个问题。那就是你要上交的报表是以今天的日期减去1得到的工作表名称（1-31），假设今天是2005-07-01,a=day(now)-1,则a=0;换句话说，VBA会找不到名称为"0"的工作表。所以建议是提交本日a=day(now)的报表，这样就不会有问题了
作者: 晓月清风 时间: 2005-6-25 17:32
MyString = "No"这句也是多余的，因为对话框只给出两个选项--“是”或者“否”
作者: secowu 时间: 2005-6-25 18:35
非常感谢，那就得加段代码，首先判断当前日期如果当前日期day(now())=1的话，则变量A的值应该为A+1其余不变对吧？谢谢晓月清风的热心帮助！！！！！！！！！！
作者: secowu 时间: 2005-6-25 18:41
那么这段代码是否还可以进行优化呢？Private Sub Workbook_open()
Dim a As String '将A定义为字符串
Dim mypath As String
Dim myfile As String
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢"
Style = vbYesNo + vbInformation + vbDefaultButton1
Title = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ If Day(Now()) = 1 Then
a = a + 1
Sheets(Array(a, "黄小姐")).Select
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝突然又想起代码中还存在着一个问题。那就是你要上交的报表是以今天的日期减去1得到的工作表名称（1-31），假设今天是2005-07-01,a=day(now)-1,则a=0;换句话说，VBA会找不到名称为"0"的工作表。所以建议是提交本日a=day(now)的报表，这样就不会有问题了
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Else
Sheets(Array(a, "黄小姐")).Select
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Else
MyString = "No"
Sheets("黄小姐").Activate
End If
End Sub
作者: 晓月清风 时间: 2005-6-25 21:22
If Day(Now()) = 1 Then
a = a + 1这样写的话，a=2,复制的工作表是2，而不是1。根据你的设计意思，如果今天是2005年6月1日，是不是要复制工作表31(2005-5-31),也就是前一个月的最后一天?
作者: 晓月清风 时间: 2005-6-25 21:26
如果是这样的话，具体代码如下：Private Sub Workbook_open()
Dim a As String '将A定义为字符串
Dim mypath As String
Dim myfile As String
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢"
Style = vbYesNo + vbInformation + vbDefaultButton1
Title = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
'求出上一个月最后一天的数值，如现在是6月，则上个月最后一天为31
End If
Sheets(Array(a, "黄小姐")).Select
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Else
MyString = "No"
Sheets("黄小姐").Activate
End If
End Sub
作者: 晓月清风 时间: 2005-6-26 23:22
代码优化如下：
Private Sub Workbook_open()
Dim a As String
If MsgBox("要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢", vbOKCancel, "请在生成后检查！！！谢谢") = vbOK Then
a = Day(Now) - 1
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
End If
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\报表.xls"
Else
Sheets("黄小姐").Activate
End If
End Sub
作者: secowu 时间: 2005-6-27 19:56
非常感谢晓月清风，
我怎么就没想到呢
原来，还要考虑上个月的那一天
由于目前在报表中，使用的是一个月一份总表，要上交的时候则复制前一天的工作表就可以了。
如果加上这一句
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
当日期为月份的第一天时，打开报表的时候，比如打开的是当前月份的，则会出现找不到的现象
对吧？
由于这些报表，只能是当天做前一天的，因为当天的数据还没有全部出来。
所以，只能做前一天的，那交报表也就只能交前一天的。
那么，是否还可以做成别的格式？
因为，我发现一个月的报表31天算有5.6M之多，加上共享工作簿，两个人同时打开时就非常的慢
而报表里只是每个月的每天进行累计，但月不累计
所以， 有点烦。
我考虑过用ACCESS，可能会更好用。
但搞不定。
发个样表上来请大师帮忙看看
表里有变量，我想要是做成ACCESS，还得保留这些变量，可以进行随时更改。
做成固定，就麻烦的。
[此贴子已经被作者于2005-6-27 16:28:04编辑过]
作者: 晓月清风 时间: 2005-6-28 00:13
不好意思，我对ACCESS不是很熟悉，不过你可以到这个论坛的ACCESS部分去求教
作者: 晓月清风 时间: 2005-6-28 00:19
以下是引用secowu在2005-6-27 11:56:00的发言：
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
当日期为月份的第一天时，打开报表的时候，比如打开的是当前月份的，则会出现找不到的现象对吧？
加上这一句会提交当前工作簿中的以最后一天命名的工作表。之前，我没看过你的样表，以为这些表不全是同一个月的。
作者: secowu 时间: 2005-6-28 00:32
非常感谢热心帮助我还有个问题要请教由于负责做报表的星期天不上班，而报表的数据是每天都有的。所以，当星期一时，则要提交的报表至少有两天的。那么是否可以设定另外一个变量dim b as stringif weekday(now())=2 thenSheets(Array(a, b,"黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\上交报表.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=Falseendif那么这段，应该怎么嵌套进去呢？
作者: 晓月清风 时间: 2005-6-28 00:45
Private Sub Workbook_open()
Dim a,b As String '多定义一个变量b
If MsgBox("要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢", vbOKCancel, "请在生成后检查！！！谢谢") = vbOK Then
a = Day(Now) - 1
b = Day(Now) - 2
If Weekday(Now) = 2 Then '判断是否为星期一
Sheets(a).Activate
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\报表.xls"
Else '如果不是星期一，则执行下列代码
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
End If
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\报表.xls"
End If '结束判断星期几
Else
Sheets("黄小姐").Activate
End If
End Sub
作者: 晓月清风 时间: 2005-6-28 00:57
顺带一提，你的样表中有一句“Application.AutomationSecurity=3 ”是不是要将EXCEL安全级设置为最低，但是EXCEL并不支持这种方法.
作者: secowu 时间: 2005-6-28 16:34
哇，真的厉害嘞。我以为加这一句可以让EXCEL不会出现宏提示的对话框没想到这句就是宏，因此，这是无效的。可能只有修改注册表才有效。但是，只为开启这个文件的宏，而开放所有的宏，似乎不是个好的方法。那么，如果用添加的可信任的宏，那复杂可更多，对吧？看了你的提示，受益良多，非常感谢！！！！！！！！！！！
作者: secowu 时间: 2005-6-28 16:38
另外，又想起了一个问题：
1.
可否让这个自动生成的表中，也包含一个宏？
因为，通过这样复制后，会自动生成一个表，而这个表就已经打开了，
可不可以生成完成后，再来个提示，将复制所得的工作表用MSGBOX来个汇报呢？
这样，就有多重防出错机制了。这个我写不来，谢谢帮忙
2.
能否以复制的工作表的名称作为新生成的工作簿名呢？格式为"mm-dd" & "生产报表(上交).xls"
是不是可以这样加个判断呢？
加个定义生成的工作簿名的变量
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
dim rptName as string
我改了如下，看看有什么问题，谢谢！
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub Workbook_open()
Dim a, b ,RptName1,RptName2 As String '多定义变量b,RptName1,RptName2
If MsgBox("要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢", vbOKCancel, "请在生成后检查！！！谢谢") = vbOK Then
a = Day(Now) - 1
b = Day(Now) - 2
RptName1=Today()-1'此变量名作不是星期一时候的上交的工作簿名
RptName2=Today()-2'此变量名作为星期一时候的上交的工作簿名
If Weekday(Now) = 2 Then '判断是否为星期一
Sheets(a).Activate
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\RptName1&RptName2&生产报表(上交).xls"
Else '如果不是星期一，则执行下列代码
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
End If
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\RptName1&生产报表(上交).xls"
End If '结束判断星期几
Else
Sheets("黄小姐").Activate
End If
End Sub
不知这样行不行？
谢谢
[此贴子已经被作者于2005-6-28 9:03:01编辑过]
作者: 晓月清风 时间: 2005-6-28 17:08
以下是引用secowu在2005-6-28 8:34:00的发言：
但是，只为开启这个文件的宏，而开放所有的宏，似乎不是个好的方法。
那么，如果用添加的可信任的宏，那复杂可更多，对吧？
参考一下：http://www.office-cn.net/bbs/dispbbs.asp?boardid=108&id=29049&star=1#144244
作者: 晓月清风 时间: 2005-6-28 17:17
以下是引用secowu在2005-6-28 8:38:00的发言：
可否让这个自动生成的表中，也包含一个宏？
因为，通过这样复制后，会自动生成一个表，而这个表就已经打开了，
可不可以生成完成后，再来个提示，将复制所得的工作表用MSGBOX来个汇报呢？
这样，就有多重防出错机制了。这个我写不来，谢谢帮忙
作者: 晓月清风 时间: 2005-6-28 17:33
提醒：EXCEL中没有today()这个函数（我用的EXCEL2000）定义RptName1，RptName2这两个变量，没有太大意义。另外，把变量写成"\RptName1&RptName2&生产报表(上交).xls"，则变成文本了！倒不如在最开始多定义一个变量c, 并且c=ThisWorkbook.Path & "\" & month(now) &"-" & day(now) &"生产报表(上交).xls",然后将此句放在b=day(now)-2之后。但有个小问题：比如现在是六月一日，生成的报表则为"6-1生产报表(上交).xls",而不是"06-01生产报表(上交).xls"
作者: 晓月清风 时间: 2005-6-28 17:49
不好意思，RptName1，RptName2这两个变量还是保留的好，只是写的时候不要写在引号" "里Rptname1=month(now) & "-" & day(now)-1 RptName2=month(now) & "-" & day(now)-2
作者: 晓月清风 时间: 2005-6-28 18:10
Private Sub Workbook_open()Dim a As String, b As String, RptName1 As String, RptName2 As String
'多定义变量RptName1,RptName2,最好这样定义，否则又会出现引用名称与编号的错误If MsgBox("要现在上交报表吗？点是，将生成上交报表，点否将不生成报表。请在生成后检查！！！谢谢", vbOKCancel, "请在生成后检查！！！谢谢") = vbOK Then
a = Day(Now) - 1
b = Day(Now) - 2
RptName1 = Month(Now) & Day(Now) - 1 '此变量名作不是星期一时候的上交的工作簿名
RptName2 = Month(Now) & Day(Now) - 2 '此变量名作为星期一时候的上交的工作簿名 If Weekday(Now) = 2 Then '判断是否为星期一
Sheets(a).Activate
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & RptName2 & "和" & RptName1 & "生产报表(上交).xls"
MsgBox "提交的工作表为：" & a & "，" & b & "，黄小姐" '提示所提交的工作表名称
Else '如果不是星期一，则执行下列代码
If a = 0 Then
a = Day(DateSerial(Year(Now), Month(Now), 0))
End If
Sheets(a).Activate
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & RptName1 & " 生产报表(上交).xls"
MsgBox "提交的工作表为：" & a & "，黄小姐" '提示所提交的工作表名称
End If '结束判断星期几
Else
Sheets("黄小姐").Activate
End IfEnd Sub
作者: secowu 时间: 2005-6-28 19:14
非常感谢晓月清风版主我经过了测试，下面的代码可以用了，就不知道会不会还有什么特殊的情况没想到的。谢谢Private Sub Workbook_open()
Application.AutomationSecurity = 3
Dim a As String
Dim b As String
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 = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置
If a = 0 Then '即判断当前日期是否为月初第一天，如果是则提醒打开上个月的报表
a = Day(DateSerial(Year(Now), Month(Now), 0))
MsgBox "今天的日期是" & Done & "为月初的第一天，要上交报表，请打开上个月的报表，并自行手动复制"
Else
If Weekday(Now) = 2 Then '判断是否为星期一
b = a - 1
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "和" & RptName2 & "上交报表之生产：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & a & "号的与" & b & "号的，请注意检查！！！！完成于" & Done
Else
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "上交报表之生产：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & a & "号的，请注意检查！！！！完成于" & Done
End If
End If
End If
End Sub
作者: 晓月清风 时间: 2005-6-28 19:24
你的代码中还是含有“Application.AutomationSecurity = 3”这一句，在你的EXCEL中能通过测试吗？。我用的是EXCEL2000调试中，马上就提醒该句出错，如果的确要避免出现提问是否启用宏，可以使用一下VBA数字签名的方法。暂时没有发现其它的代码有什么问题。
作者: secowu 时间: 2005-6-28 19:46
哦。真不好意思忘了那句要DEL了。在OFFICE 2003里可以通过测试的谢谢
作者: secowu 时间: 2005-7-2 03:27
这是新出现的问题：当日期为月初第一天的时候，比如今天：2005-07-01，宏提示说因为是月初，所以要手动复制因为，当日期是月初的时候，作报表的人，其实还是在做前个月的，要上交的报表也是前个月的。所以，宏就不会正确判断并提交报表了。为了解决这个问题：我构想了一下：就是原报表名"以YYYY-MM生产报表.XLS"的格式命名，这样，在宏里面就可以加个一个判断：当获得的文件名与当前系统日期Format(yyyy-mm,NOw())相同的时候，就执行a = Day(DateSerial(Year(Now), Month(Now), 0))
并进行报表的复制如果不是，则现出提示说打开正确的生产报表进行复制以上交。通过，这样判断，就基本上解决了日期问题而导致无法正确复制上交报表的情况。那么，应该如何，修改下面的代码呢？非常感谢！！！！如下代码：Private Sub Workbook_open()
Dim a As String
Dim b As String
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 = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置
If a = 0 Then '即判断当前日期是否为月初第一天，如果是则提醒打开上个月的报表
a = Day(DateSerial(Year(Now), Month(Now), 0))
MsgBox "今天的日期是" & Done & "为月初的第一天，要上交报表，请打开上个月的报表，并自行手动复制"
Else
If Weekday(Now) = 2 Then '判断是否为星期一
b = a - 1
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "和" & RptName2 & "上交报表之生产：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & a & "号的与" & b & "号的，请注意检查！！！！完成于" & Done
Else
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "上交报表之生产：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & a & "号的，请注意检查！！！！完成于" & Done
End If
End If
End If
End Sub
作者: secowu 时间: 2005-7-2 03:56
全部详细的见第一楼的贴子，谢谢大家帮助，特别是晓月清风同时感谢与特别欢迎各位高手提供修改意见！！！！！！！
作者: secowu 时间: 2005-7-2 16:05
非常期待并感谢晓月清风等高手大侠帮助！！
作者: secowu 时间: 2005-7-2 16:18
宏表函数 1、get.cell(66)定义一个名称，简写为：mc,引用位置写入"=get.cell(66)"然后在任意单元格输入=mc,即可得到当前工作簿名称。文件名函数.xls =mc2、get.cell(62)[或get.cell(32)]定义一个名称，简写为：mcb,引用位置写入"=get.cell(62)或=get.cell(32),然后在任意单元格输入=mcb,即可得到当前工作簿及工作表名称。[文件名函数.xls]sheet1 =mcb[文件名函数.xls]sheet1 =mcb2怎么定义一个名称，引用位置，不明白？
作者: secowu 时间: 2005-7-2 16:20
=CELL("filename",A1)可以得到包含路径的工作表名。配合mid和find函数就能取到文件名和表名。
作者: secowu 时间: 2005-7-2 16:20
=MID(CELL("filename",$A$1),LEN(CELL("filename",$A$1))-10,2)&"-"&MID(CELL("filename",$A$1),LEN(CELL("filename",$A$1))-8,2)&"-"&RIGHT(CELL("filename",$A$1),2)
作者: secowu 时间: 2005-7-2 20:33
顶上去啊我顶
作者: secowu 时间: 2005-7-2 21:22
有人帮我吗？没人，只好用老办法了。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 = "请在生成后检查！！！谢谢"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Yes"
a = Day(Now) - 1 '定义出需要复制的工作表名
mypath = ThisWorkbook.Path ''获得当前文件存放的位置
If a = 0 Then '即判断当前日期是否为月初第一天，如果是则提醒打开上个月的报表
MsgBox "本月是月初的第一天，请检查打开的生产报表为上个月的，请仔细检查生成的报表是否正确！谢谢"
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 _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & c & "月" & a & "号的，请注意检查！！！！完成于" & Done
Else
If Weekday(Now) = 2 Then '判断是否为星期一
b = a - 1
Sheets(Array(a, b, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "和" & RptName2 & "的生产报表(上交)：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的与" & b & "号的，请注意检查！！！！完成于" & Done
Else
Sheets(Array(a, "黄小姐")).Copy
ActiveWorkbook.SaveAs Filename:= _
mypath & "\" & RptName1 & "的生产报表(上交)：创建于" & MyToday & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox "自动生成上交的工作表为：" & Month(Now) & "月" & a & "号的，请注意检查！！！！完成于" & Done
End If
End If
End If
End Sub
作者: 晓月清风 时间: 2005-7-3 18:46
啊，不好意思，昨天超忙，连上网的时间都没有，没能及时帮你解决问题。已根据你的要求改进代码如下，在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
作者: secowu 时间: 2005-7-4 00:29
非常感谢清风明月版主我明天上班才调试下.祝您周末快乐!!!!!!!!!!!!!!!!!!!!!!!非常感谢
作者: secowu 时间: 2005-7-4 00:37
我是后来这样想了一个办法,但没写出可行的代码来:因为,每个报表的工作表里都有一个单元格是记录日期的.所以,我就想,可以先获得那个单元格的内容,得到像这样的字符: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 时间: 2005-7-4 00:40
我还是很喜欢这个版,清风明月版主很令我感动呀.
作者: secowu 时间: 2005-7-4 16:32
非常感谢晓月清风经过测试，当打开的文件名中与系统的日期前7位不同时，会出现不作为的情况。
作者: secowu 时间: 2005-7-4 16:46
我经过测试了，这个可以引用单元格的值，然后进行判断打开的报表与系统的时间问题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 时间: 2005-7-4 18:58
麻烦看看下面的问题：经过考虑，大概有下面情况：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 _
作者: 晓月清风 时间: 2005-7-4 23:34
第二点和第五点有何差别?
2.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，分类：周一或非周一。执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的
5.报表里的标记日期里的月份M1＝当前系统日期里的月份时M2，并且A<>0不是月初第一天时，执行报表复制，分类：周一或非周一。 执行报表复制：分日期是否为星期一，是则复制两天，否复制一天的
感觉好混乱!!!!
作者: secowu 时间: 2005-7-5 00:00
我也感觉好乱了。条件一多，就麻烦了。精简下：先用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)就是为系统日期前一个月份时，这种情况出现在月初第一天时，执行复制但仍旧有两种情况，可能是星期一，或不是星期一提醒系统时间错误或是报表错误，并调用打开对话框 现在应该是包括了所有的情况了吧？那么怎么写代码呢？谢谢
作者: 晓月清风 时间: 2005-7-5 00:13
浏览了一下你的代码，大概明白你的意思了，但我现在没多少时间可以在网上，明天早上才有空,再提供完整代码供你参考。
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-5 00:41
谢谢主。If Weekday(Now) = 2 Then '判断是否为星期一
b = a - 1
Sheets(Array(a, b, "黄小姐")).Copy
'这里出现下标越界？怎么解决呢？
'在EXCEL2000中，并不会出现“下标越界”我用MSG进行测试了，原来是a值为0，所以出错了。
作者: 晓月清风 时间: 2005-7-5 16:10
以下是引用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 ,所以没发现错误。
作者: 晓月清风 时间: 2005-7-5 16:20
根据你的五点要求，是要求当A=0，即在月初时，自动打开正确的报表后，又让EXCEL自动在新打开的报表文件中提交正确的报表，而不是原来的手动复制了！并且如果上个月最后一天刚好也是星期一时，则要复制两张报表，这就必须再增加判断上个月最后一天是否为星期一。有点不好办！另外，当你调用“打开”对话框，并打开一个具有相同代码的报表文件（2005-06.xls)，就会运行WORKBOOK_OPEN（），也就是一打开就提示是否提交报表，按"是"则提交相应的报表。如果今天是月初，则又提示打开新的文件报表。而且在原报表文件（2005-07.xls）打开新报表文件后，接下来的代码都将不会被执行，因为焦点已转移到新的工作簿文件中的宏。
[此贴子已经被作者于2005-7-5 8:35:29编辑过]
作者: secowu 时间: 2005-7-5 16:44
以下是引用晓月清风在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编辑过]
作者: 晓月清风 时间: 2005-7-5 17:57
测试一下以下的代码，看看还有什么问题：
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
作者: 晓月清风 时间: 2005-7-5 19:23
x = Weekday(DateSerial(Year(Now), Right(RPTDate, 1) + 1, a))
这句应该改为：x=Weekday(DateSerial(Year(Now), Right(RPTDate, 1) , a))，再加一的话就是判断本月最后一天是否为星期一了。我测试了一下，就发现了这个问题
作者: secowu 时间: 2005-7-5 20:38
非常感谢，我这就去测试下
作者: secowu 时间: 2005-7-5 20:44
刚测试完毕，发现完全正确真的非常感谢而且这样，代码也精简了许多，看了一目了然厉害，还请多多指教再次感谢
作者: secowu 时间: 2005-7-5 22:10
这是最后修改的代码：非常感谢晓月清风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
作者: 晓月清风 时间: 2005-7-5 22:53
刚刚又进行了一次测试，发现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
| 欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) |
Powered by Discuz! X3.3 |