那位大神帮我在这段代码里面加上新建文件夹的代码！

yuyubiao

lkuhcc 发表于 2023-5-2 11:59
这个代码里面,增一个,保存文档的代码.
就是在做运行完下面的代码之后,把当前XLS原文件做一个保存的动作. ...

Sub 备份另存为PDF()
On Error Resume Next
Dim sPath1 As String,sPath2 As String
Dim sName As String
sPath1 = ActiveWorkbook.path & "\备份\" '新建文件夹名
sPath2= ActiveWorkbook.path & "\提交\" '新建文件夹名
If Dir(sPath1, vbDirectory) = "" Then
MkDir sPath1
MkDir sPath2
End If
sName = sPath1 & [O1] & ".pdf" '文件名单元格
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sName, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
ActiveWorkbook.Save
End Sub

lkuhcc

yuyubiao 发表于 2023-5-2 23:08
Sub 备份另存为PDF()
On Error Resume Next
Dim sPath1 As String,sPath2 As String

如何根据这段保存为PDF的代码改成下面的功能.

把当前工作簿(不是整个文档)带页面格式另存为新的EXL文件,并打开新文件.
新文件里面单元格内容只保留结果值,不要里面公式.
--------------------------------------------------------
Sub 备份当前工作簿()
On Error Resume Next
Dim sPath1 As String’新建两个文件夹的代码
Dim sName As String
sPath1 = ActiveWorkbook.path & "\备份\" '新建文件夹名1
If Dir(sPath, vbDirectory) = "" Then
MkDir sPath1’新建第一个文件夹的代码
End If
sName = sPath1 & [O1] &"-备份" &Format(Date, "yyyyMMdd") & Format(Time, "hhmmss") & ".pdf" '文件名单元格+单据名称+打印日期时间,并存到第一个文件夹
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sName, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
ActiveWorkbook.Save’保存当前文档
End Sub

yuyubiao

1. Sub 备份当前工作簿()
   
2. On Error Resume Next
   
3. Dim sPath1 As String'新建两个文件夹的代码
   
4. Dim sName As String, sheetName As String
   
5. sheetName = ActiveSheet.Name
   
6. sPath1 = ActiveWorkbook.path & "\备份" '新建文件夹名1
   
7. If Dir(sPath, vbDirectory) = "" Then
   
8. MkDir sPath1'新建第一个文件夹的代码
   
9. End If
   
10. sName = sPath1 & [O1] &"-备份" &Format(Date, "yyyyMMdd") & Format(Time, "hhmmss") & ".xlsx" '文件名单元格+单据名称+打印日期时间，并存到第一个文件夹
    
11. Application.DisplayAlerts = False '禁止弹出提示警告信息
    
12. Worksheets(sheetName).Copy '复制需要另存为的sheet
    
13. With ActiveWorkbook.Sheets(1)
    
14. .UsedRange.Value = .UsedRange.Value
    
15. End With '将公式换成数值
    
16. ActiveWorkbook.SaveAs Filename:=sName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False '保存新工作薄
    
17. ActiveWorkbook.Close False '关闭并不保存当前工作薄
    
18. Application.DisplayAlerts = True '重启警告信息显示
    
19. Workbooks.Open(sName)
    
20. End Sub

复制代码