vba - 使用可视文件选择器将每个工作表保存到单独的 xls 文件中的宏

Question

我一直在使用下面链接的解决方案，成功地将多个工作表保存到单独的 CSV，并且希望有一个类似的解决方案来保存到 XLS。我想将每个工作表分成自己的 XLS 文件，但仍然有一个文件选择器来选择它们的保存路径。

我尝试修改此代码但无济于事 - 有什么想法吗？

Save each sheet in a workbook to separate CSV files

Answer 1

此解决方案是您提供的链接中前两个解决方案的混合体。

' ---------------------- 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