on error resume next
'开启错误捕捉,出现错误,进入下一行
dim myapp as object
dim wk1 as object,wk2 as object
set myapp=CreateObject("Excel.Application")
myapp.enableevents=false
'取消EXCEL程序响应事件
myapp.calculation=-4135
'取消公式自动更新
myapp.visible=false
‘取消EXCEL程序显示
set wk1=myapp.workbooks.open("E:\REPORT.XLS",,1)
'只读打开对应的表格
if wk1 is nothing then
msgbox "打开工作表出现错误!" & chr(10) & err.description
exit sub
'如果打开工作薄错误,则退出程序
endif
err.clear
set wk2=myapp.workbooks.add
’新增空白工作薄
wk1.sheets("sheet1").cells.copy
’复制内容
wk2.sheets("sheet1").range("a1").PasteSpecial -4163 'xlpastevalues
'首先先粘贴数据内容
wk2.sheets("sheet1").range("a1").PasteSpecia -4122 ' xlpasteformats
‘再粘贴单元格格式
wk2.saveas "D:\" & format(now(),"YYYYMMDDHH") & ".xls"
’保存工作表
wk2.close 0
wk1.close 0
set wk2=nothing
set wk1=nothing
set myapp=nothing
'关闭工作薄,释放对象
'首先要将“工程-引用”中的Mic… Excel…选中
Private Sub Command1_Click()
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
On Error Resume Next
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open(App.Path & "\1.xls")
k = 5
Do While xlApp.Worksheets("Sheet1").Range("A1").Cells(k, 2) <> ""
xlApp.Worksheets("Sheet1").Range("A1").Cells(k, 3) = Format(Now, "yyyy-mm-dd")
xlApp.Worksheets("Sheet1").Range("A1").Cells(k, 4) = Format(Time, "hh:mm")
xlApp.Worksheets("Sheet1").Range("A1").Cells(k, 11) = Format(Now, "yyyy-mm-dd")
xlApp.Worksheets("Sheet1").Range("A1").Cells(k, 12) = Format(Time, "hh:mm")
k = k + 1
Loop
path1 = "C:\Documents and Settings\Administrator\桌面\"
name1 = Format(Now, "yyyymmddhhmmss") & ".xls"
ActiveWorkbook.SaveAs FileName:=path1 & name1
ActiveWorkbook.Close
xlBook.Close (True)
xlApp.Quit
Set xlApp = Nothing
End Sub
这个问题不是太难 网上有
I think you can just use file copy, it doesn't matter excel or not, then add date time for the new excel.