使用可視文件選擇器將每個工作表保存爲單獨的xls文件的宏

Question

我一直在使用下面鏈接的解決方案，將多個工作表保存爲XLS，並且希望將類似的解決方案保存爲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