单独提取当前工作表到新的工作簿

TAYM

文件格式没有问题，请大家帮助按要求位置保存文件！

ykcbf1100

附件供参考，楼主的代码没有新建成绩文件夹。

ykcbf1100

导出当前工作表。

1. Sub ykcbf()       '2024.7.4   导出为Excel文件
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set ws = ThisWorkbook
   
5.     fn = Split(ws.Name, ".")(0)
   
6.     Set sh = ws.ActiveSheet
   
7.     p = ws.Path & "\成绩"
   
8.     If Dir(p, vbDirectory) = "" Then MkDir p
   
9.     sh.Copy
   
10.     Set wb = ActiveWorkbook
    
11.     wb.SaveAs p & fn & "-" & sh.Name
    
12.     wb.Close
    
13.     Application.ScreenUpdating = True
    
14.     MsgBox "OK！"
    
15. End Sub
    

复制代码

TAYM

ykcbf1100 发表于 2024-7-4 15:37
附件供参考，楼主的代码没有新建成绩文件夹。

感谢您的帮助：
If Dir(p, vbDirectory) = "" Then MkDir p 报错，请调试

Qs18

Sub 导出为Excel文件()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim strPatph As String
    '判断当前文件路径是否有成绩的文件夹，没有就创建，有就反馈一下路径=============
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = ThisWorkbook.Path & "\成绩\" '设置你想要检查的文件夹路径
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" '确保路径以反斜杠结束
    '尝试获取文件夹对象
    On Error Resume Next
    Set folder = fso.GetFolder(folderPath)
    If Err.Number <> 0 Then
        '如果文件夹不存在，则创建文件夹
        fso.CreateFolder folderPath
        MsgBox "文件夹已创建: " & folderPath
    Else
        '文件夹已存在
        MsgBox "文件夹已存在: " & folderPath
    End If
    On Error GoTo 0 ' 重置错误处理
   '判断当前文件路径是否有成绩的文件夹，没有就创建，有就反馈一下路径=============
    ThisWorkbook.ActiveSheet.Copy
    strpath = ThisWorkbook.Path & "\成绩\"
    s = InputBox("请输入导出文件名：", "输入提示", "2024年上期期末教学质量监测学生成绩册（）")
    ActiveWorkbook.SaveAs strpath & s & ".xlsx"
    ActiveWindow.Close
    Set folder = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Qs18

试试...........

Qs18

试一下..............

TAYM

Qs18 发表于 2024-7-4 19:59
试一下..............

请问假如要导出为pdf格式又怎么办？

Qs18

Sub 导出为pdf文件() 'qs2024/7/5
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim strPatph As String
    '判断当前文件路径是否有成绩的文件夹，没有就创建，有就反馈一下路径=============
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = ThisWorkbook.Path & "\成绩\" '设置你想要检查的文件夹路径
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" '确保路径以反斜杠结束
    '尝试获取文件夹对象
    On Error Resume Next
    Set folder = fso.GetFolder(folderPath)
    If Err.Number <> 0 Then
        '如果文件夹不存在，则创建文件夹
        fso.CreateFolder folderPath
        MsgBox "文件夹已创建: " & folderPath
    Else
        '文件夹已存在
        MsgBox "文件夹已存在: " & folderPath
    End If
    On Error GoTo 0 ' 重置错误处理
   '判断当前文件路径是否有成绩的文件夹，没有就创建，有就反馈一下路径=============
    ThisWorkbook.ActiveSheet.Copy
    strpath = ThisWorkbook.Path & "\成绩\"
    s = InputBox("请输入导出文件名：", "输入提示", "2024年上期期末教学质量监测学生成绩册（）")
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strpath & s & ".pdf"
    ActiveWindow.Close
    Set folder = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Qs18

导出为pdf..........