POP Up Dialogue for browsing a folder to save multiple worksheets

[RiciH83]

I'm fairly new to VBA but been working on some code that basically saves each worksheet as its own workbook into a designated folder / path.

This works fine however i have to manually enter the destination for the files to be saved.

What i want is a pop up box to be able to browse through folders etc and select the detination.

But i'm stumpt

Here is the code below i'm using

Thank you

Sub Savepertab()
'Creates an individual workbook for each worksheet in the active workbook.
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object 'Could be chart, worksheet, Excel 4.0 macro,etc.
Dim strSavePath As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False 'Don't show any screen movement
 
'Destination Folder Need to create a browse options
strSavePath = "Manually entered Path"
 
Set wbSource = ActiveWorkbook
For Each sht In wbSource.Sheets
sht.Copy
Set wbDest = ActiveWorkbook
wbDest.SaveAs strSavePath & sht.Name
wbDest.Close 'Remove this if you don't want each book closed after saving.
Next
Application.ScreenUpdating = True

 

[Andrew Poulsom]

Look here:

http://www.dailydoseofexcel.com/archives/2004/06/10/getsaveasfilename/

 

[RoryA]

you could use this function:

Function GetFolder() As String
    Dim dlg As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    If dlg.Show = -1 Then
        GetFolder = dlg.SelectedItems(1)
    End If
End Function

 

[RiciH83]

Thank you andrew.

I attempted to try the link you provided but came up with the same errors that other people had been experiencing.

and i tried to use the function but again had not luck so anymore ideas would be very helpful.

Thank you

 

[RoryA]

What problem did you have with the function? (and which version of Excel?)

 

[Andrew Poulsom]

I changed the quotes in the procedure so that it compiles:

Sub SaveTextFile()
    Dim sFname As String
    Dim lFnum As Long
    Dim rRow As Range
    Dim rCell As Range
    Dim sOutput As String
    sFname = Application.GetSaveAsFilename( _
        InitialFileName:="MyTabDelim.txt", _
        FileFilter:="Text files, *.txt", _
        Title:="Save Tab Delimited File")
    If sFname <> "False" Then
        lFnum = FreeFile
        Open sFname For Output As lFnum
        For Each rRow In Sheet1.UsedRange.Rows
            For Each rCell In rRow.Cells
                sOutput = sOutput & rCell.Text & vbTab
            Next rCell
            Print #lFnum, sOutput
            sOutput = ""
        Next rRow
        Close lFnum
    End If
End Sub

 

[RiciH83]

Mr Poulsom u are a genius.

All working now.

Thank you for you help and also thank you rorya for looking into.