[已解决]转载一个难题,请老大看看能否解决

一点不自在

转载一个难题,请老大看看能否解决

一个问题求答:
用某模板中做了数据表,然后把数据表另存到F:\ 下为普通工作簿, 取名规律是 " 当天的月日+序号+后缀名"
当天第一次保存时,文件名中的序号为"0",第二次保存时,文件名中的序号为"1",依此类推
比如今天用模板做了数据表,第一次保存的新工作簿文件名就是 1月22日0.XLT
如果今天再次用模板做了数据表,再次保存,那么当天第二次保存的新工作簿文件名就是 1月22日1XLT,
保存时不出任何提示信息,自动完成,
因为模板不可以更改后保存,所以记数不能从原文件中提取,不知道如何去完成上面的功能,请大师指导.

最佳答案

月排行榜 / 总排行榜

FookYou

2010-1-25 16:03

9vqDEJHG.rar (10.39 KB, 下载次数: 10)

2010-1-25 16:03 上传

点击文件名下载附件
转载一个难题,请老大看看能否解决
Sub 复制并保存()
  Dim xlName$, sDate$, k%
  Dim xlWb As Workbook
  Dim xlWs As Worksheet
  Dim Arr() As Integer
    Application.ScreenUpdating = False      '禁止屏幕刷新
    Application.DisplayAlerts = False       '警告框不显示,有同名工作簿直接覆盖
    Range("A1:I23").Copy
    Set xlWb = Workbooks.Add
    Set xlWs = xlWb.Sheets(1)
    xlWs.Activate
    ActiveSheet.Paste
    ActiveSheet.Columns("A:I").EntireColumn.AutoFit
    sDate = Format(Date, "mm月dd日")
    If Dir("E:\" & sDate & "*.xls") = "" Then
      xlWb.SaveAs Filename:="E:\" & sDate & "0.xls"
      GoTo Exit_复制并保存
    End If
    xlName = Dir("E:\" & sDate & "*.xls")
    Do While xlName <> ""
      k = k + 1
      ReDim Preserve Arr(1 To k)
      Arr(k) = Mid(xlName, InStr(xlName, ".") - 1, 1)
      xlName = Dir
    Loop
    xlWb.SaveAs Filename:="E:\" & sDate & Application.Max(Arr) + 1 & ".xls"
   
Exit_复制并保存:
    xlWb.Close
    Application.CutCopyMode = False
    Application.DisplayAlerts = True        '恢复警告
    Application.ScreenUpdating = True       '恢复屏幕刷新
End Sub

跳转到最佳答案楼层

FookYou

先检查"F:\"是否有"11月22日*.XLT",没有就生成"1月22日0.XLT"、有就生成"1月22日'*+1'.XLT"

qiejiang

模版可以修改啊？

一点不自在

二楼的星宿老仙理解真确,可是菜鸟不会做,还请星宿老仙在附件上做个实例了.

iJ29W9t6.rar (9.19 KB, 下载次数: 9)

2010-1-22 14:23 上传

点击文件名下载附件

[此贴子已经被作者于2010-1-22 14:23:13编辑过]

一点不自在

老仙理解的很正确,可是菜鸟不会修改,请老仙在附件中做个实例吧

zzk386

也想占位学习,是不是难倒大家了吗?

不可思议.....[em06]

[此贴子已经被作者于2010-1-23 13:09:39编辑过]

FookYou

9RjR9Rz5.rar (9.3 KB, 下载次数: 1)

2010-1-24 02:56 上传

点击文件名下载附件
转载一个难题,请老大看看能否解决
Sub 复制并保存()
  Dim xlName$, sDate$
  Dim xlWb As Workbook
  Dim xlWs As Worksheet
    Application.ScreenUpdating = False      '禁止屏幕刷新
    Application.DisplayAlerts = False       '警告框不显示,有同名工作簿直接覆盖
    Range("A1:I23").Copy
    Set xlWb = Workbooks.Add
    Set xlWs = xlWb.Sheets(1)
    xlWs.Activate
    ActiveSheet.Paste
    ActiveSheet.Columns("A:I").EntireColumn.AutoFit
    sDate = Format(Date, "mm月dd日")
    xlName = Dir("E:\" & sDate & "*.xls")
    If xlName = "" Then
      xlWb.SaveAs Filename:="E:\" & sDate & "0.xls"
    Else
      Kill "E:\" & xlName
      xlWb.SaveAs Filename:="E:\" & sDate & Mid(xlName, InStr(xlName, ".") - 1, 1) + 1 & ".xls"
    End If
    xlWb.Close
    Application.CutCopyMode = False
    Application.DisplayAlerts = True        '恢复警告
    Application.ScreenUpdating = True       '恢复屏幕刷新
End Sub

一点不自在

谢谢老仙,可是于要求有些出入:一天中保存几次文件,就要保留几个文件,现在的情况是第二次保存文件时把第一次的文件删除了!

 我把这句变成注释 'Kill "E:\" & xlName

第二次保存文件就不会删除第一次的文件了,但问题又来了,一天中只能保存二次文体,再保存就不见前面的文件了,

请老仙再修改一下.

[em04]

FookYou

9vqDEJHG.rar (10.39 KB, 下载次数: 10)

2010-1-25 16:03 上传

点击文件名下载附件
转载一个难题,请老大看看能否解决
Sub 复制并保存()
  Dim xlName$, sDate$, k%
  Dim xlWb As Workbook
  Dim xlWs As Worksheet
  Dim Arr() As Integer
    Application.ScreenUpdating = False      '禁止屏幕刷新
    Application.DisplayAlerts = False       '警告框不显示,有同名工作簿直接覆盖
    Range("A1:I23").Copy
    Set xlWb = Workbooks.Add
    Set xlWs = xlWb.Sheets(1)
    xlWs.Activate
    ActiveSheet.Paste
    ActiveSheet.Columns("A:I").EntireColumn.AutoFit
    sDate = Format(Date, "mm月dd日")
    If Dir("E:\" & sDate & "*.xls") = "" Then
      xlWb.SaveAs Filename:="E:\" & sDate & "0.xls"
      GoTo Exit_复制并保存
    End If
    xlName = Dir("E:\" & sDate & "*.xls")
    Do While xlName <> ""
      k = k + 1
      ReDim Preserve Arr(1 To k)
      Arr(k) = Mid(xlName, InStr(xlName, ".") - 1, 1)
      xlName = Dir
    Loop
    xlWb.SaveAs Filename:="E:\" & sDate & Application.Max(Arr) + 1 & ".xls"
   
Exit_复制并保存:
    xlWb.Close
    Application.CutCopyMode = False
    Application.DisplayAlerts = True        '恢复警告
    Application.ScreenUpdating = True       '恢复屏幕刷新
End Sub

一点不自在

谢谢老仙,用过啦,很好,再能把说明写得详细点吗[em17]