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

secowu

哇，真的厉害嘞。我以为加这一句可以让EXCEL不会出现宏提示的对话框没想到这句就是宏，因此，这是无效的。可能只有修改注册表才有效。但是，只为开启这个文件的宏，而开放所有的宏，似乎不是个好的方法。那么，如果用添加的可信任的宏，那复杂可更多，对吧？看了你的提示，受益良多，非常感谢！！！！！！！！！！！

secowu

另外，又想起了一个问题：

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

晓月清风

以下是引用secowu在2005-6-28 8:34:00的发言：



但是，只为开启这个文件的宏，而开放所有的宏，似乎不是个好的方法。

那么，如果用添加的可信任的宏，那复杂可更多，对吧？

参考一下：http://www.office-cn.net/bbs/dispbbs.asp?boardid=108&id=29049&star=1#144244  

晓月清风

以下是引用secowu在2005-6-28 8:38:00的发言：



可否让这个自动生成的表中，也包含一个宏？

因为，通过这样复制后，会自动生成一个表，而这个表就已经打开了，

可不可以生成完成后，再来个提示，将复制所得的工作表用MSGBOX来个汇报呢？

这样，就有多重防出错机制了。这个我写不来，谢谢帮忙

这个只要在"ActiveWorkbook.SaveAs...." 后增加一句：MsgBox "上交的报表为工作表" & a & b即可

晓月清风

提醒：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"

晓月清风

不好意思，RptName1，RptName2这两个变量还是保留的好，只是写的时候不要写在引号" "里Rptname1=month(now) & "-" & day(now)-1 RptName2=month(now) & "-" & day(now)-2

晓月清风

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

非常感谢晓月清风版主我经过了测试，下面的代码可以用了，就不知道会不会还有什么特殊的情况没想到的。谢谢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

晓月清风

你的代码中还是含有“Application.AutomationSecurity = 3”这一句，在你的EXCEL中能通过测试吗？。我用的是EXCEL2000调试中，马上就提醒该句出错，如果的确要避免出现提问是否启用宏，可以使用一下VBA数字签名的方法。暂时没有发现其它的代码有什么问题。

secowu

哦。真不好意思忘了那句要DEL了。在OFFICE 2003里可以通过测试的谢谢