vba 使用可视文件选择器将每个工作表保存到单独的 xls 文件中的宏
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/9572342/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
macro to save each worksheet into separate xls files with visual file chooser
提问by Rachel Arts
I have been using the solution linked below with much success for saving multiple worksheets to separate CSVs and would like a similar solution for saving to XLS. I would like to separate each worksheet into their own XLS file but still have a file chooser to choose the path they are saved to.
我一直在使用下面链接的解决方案，在将多个工作表保存到单独的 CSV 方面取得了很大的成功，并且想要一个类似的解决方案来保存到 XLS。我想将每个工作表分成他们自己的 XLS 文件，但仍然有一个文件选择器来选择它们的保存路径。
I've tried to modify this code to no avail - any ideas?
我试图修改此代码无济于事 - 有什么想法吗？
回答by Marc
This solution is a hybrid of the top two from the link you provided.
此解决方案是您提供的链接中前两个的混合。
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim xlsPath As String
xlsPath = GetFolderName("Choose the folder to export files to:")
If xlsPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If
'MsgBox xlsPath
For Each wsSheet In Worksheets
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
wsSheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=xlsPath + "\" + wsSheet.Name & ".xls", CreateBackup:=False
ActiveWorkbook.Close
Next wsSheet
End Sub
