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

secowu

这是新出现的问题：当日期为月初第一天的时候，比如今天：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

全部详细的见第一楼的贴子，谢谢大家帮助，特别是晓月清风同时感谢与特别欢迎各位高手提供修改意见！！！！！！！

secowu

非常期待并感谢晓月清风等高手大侠帮助！！

secowu

宏表函数　　　　　　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

=CELL("filename",A1)可以得到包含路径的工作表名。配合mid和find函数就能取到文件名和表名。

secowu

=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

顶上去啊我顶

secowu

有人帮我吗？没人，只好用老办法了。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

晓月清风

啊，不好意思，昨天超忙，连上网的时间都没有，没能及时帮你解决问题。已根据你的要求改进代码如下，在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

非常感谢清风明月版主我明天上班才调试下.祝您周末快乐!!!!!!!!!!!!!!!!!!!!!!!非常感谢