部份工作表保存成为一个或几个独立的工作簿

opklnm1108

求助：部份工作表保存成为一个或几个独立的工作簿。感谢！！！

    1、设置一个时间在工程模块中，与电脑系统时间相比，到期后若打开该工作簿自动将本工作簿的工作表“01”、“02”及“03”保存成一个工作簿（含这3个工作表）或三个独立的工作簿；
       2、生成的工作簿保存到桌面，并且提示相关数据已保存桌面（所生成工作簿的名称为工作表表名&当时时间到秒.xlsm）；
       3、删除原工作簿中所有工作表后单独生成一个工作表，其工作表表名为“空白”，工作簿名称不变，自动保存并关闭放置在原路径。

       4、保证再次打开原工作簿不会出错。

ynzsvt

1. Sub 宏1()
   
2.     Sheets(Array("01", "02", "03")).Move
   
3. End Sub

复制代码

ynzsvt

1. Sub 宏1()
   
2.     Sheets(Array("01", "02", "03")).Move
   
3. End Sub

复制代码

3190496160

Private Sub Workbook_Open()
If Date > #4/30/2024# Then
    Dim oWShell
    Set oWShell = CreateObject("WScript.Shell")
    lj = oWShell.SpecialFolders("Desktop")
    Sheets(Array("01", "02", "03")).Copy
    ActiveWorkbook.SaveAs Filename:=lj & "\基础数据" & Format(Now(), "yyyymmddHmmss")
    ActiveWorkbook.Close
    MsgBox "提示相关数据已保存桌面"
End If
End Sub

3190496160

20240612.rar (49.17 KB, 下载次数: 9)

2024-6-14 08:33 上传

点击文件名下载附件

3190496160

具体日期自己修改，第三点不知道是什么意思

lcs_2046

Sub shtmove ()
If not isExistSheetName then
Worksheet. Add after:=Sheets(sheets. Count)
Activesheet. Name="空白
End if
For i=1 to sheets. Count
Sheets("0"&i).move
With activeworkbook
.saveas '保存路径
.close
End with
Next i
End sub

Sub isexistsheetname (sheetname )
Dim sht  as worksheet
isexistsheetname=false
On error  resume next
Set sht =worksheets(sheetname )
If  err. Number=0 then
isexistsheetname=true
End if
On error  goto  0
End sub
'这里isexistsheetname 是自定义函数，用来判断工作表"空白"是否存在
手机写的，调试下再用

lcs_2046

保存这块肯定有问题的，看4楼的吧

ykcbf1100

最后一部分代码慎用，我暂时注销了，你想用可以启用

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.14
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & ""
   
5.     Set ws = ThisWorkbook
   
6.     TargetDate = "2024/7/1"
   
7.     fn = [{"01","02","03"}]
   
8.     If Date >= TargetDate Then
   
9.         ws.Sheets(fn).Copy
   
10.         Set wb = ActiveWorkbook
    
11.         f = p & Split(ws.Name, ".")(0) & "_" & Format(Now, "yyyy-mm-dd HH-MM-SS")
    
12.         wb.SaveAs f, 52
    
13.         wb.Close
    
14.         MsgBox "新工作簿已保存到桌面！"
    
15.     End If
    
16.     '//以下这部分代码慎用,不然,里面的表会被删得只剩下"空白"一个表,先注销,如你想用可以启用
    
17.     '**************************************************************
    
18. '    With ws
    
19. '        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "空白"
    
20. '        For Each sht In .Sheets
    
21. '            If sht.Name <> "空白" Then
    
22. '                sht.Delete
    
23. '            End If
    
24. '        Next
    
25. '    End With
    
26. '    Application.Quit
    
27.     '****************************************************************
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    
30. 
    

复制代码