自由选择保存目录保存为指定文件

hhxq001

怎么自选保存目录并保存为指定的文件

选择保存路径.rar (22.1 KB, 下载次数: 5)

2024-7-19 17:15 上传

点击文件名下载附件

ykcbf1100

另存文件夹可选，默认是当前目录

ykcbf1100

当前表另存

1. Sub ykcbf()  '//2024.7.19   当前表另存
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = -1 Then
   
8.             p = .SelectedItems(1) & ""
   
9.         End If
   
10.     End With
    
11.     Sheets("提取表").Copy
    
12.     Set wb = ActiveWorkbook
    
13.     wb.Sheets(1).DrawingObjects.Delete
    
14.     wb.SaveAs p & "提取表"
    
15.     wb.Close
    
16.     Application.ScreenUpdating = False
    
17.     MsgBox "OK！"
    
18. End Sub
    
19. 
    

复制代码

hhxq001

ykcbf1100 发表于 2024-7-19 20:32
当前表另存

如果在选择路径的时候还要自己给文件起名，怎么实现

ykcbf1100

hhxq001 发表于 2024-7-22 10:20
如果在选择路径的时候还要自己给文件起名，怎么实现

改好了。。。

ykcbf1100

文件名自录

1. Sub ykcbf()  '//2024.7.22   当前表另存
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = -1 Then
   
8.             p = .SelectedItems(1) & ""
   
9.         End If
   
10.     End With
    
11.     fn = Application.InputBox("请输入要保存的文件名：", "文件名自行输入", "提取表")
    
12.     Sheets("提取表").Copy
    
13.     Set wb = ActiveWorkbook
    
14.     wb.Sheets(1).DrawingObjects.Delete
    
15.     wb.SaveAs p & fn
    
16.     wb.Close
    
17.     Application.ScreenUpdating = False
    
18.     MsgBox "OK！"
    
19. End Sub
    
20. 
    

复制代码