Excel VBA - Allow users to choose folder to save file

[MWPope]

I would like to create a macro button that forces department managers (over 120) to save a monthly variance Excel file using a prescribed naming convention based on cells in the file but allow them to choose the folder in which they save the file.

I have wasted 6 hours trying to find ways to open a folder browser to replace my "C:\Documents and Settings\compope\Desktop\" with the folder managers are free to choose.

I would appreciate any help as I'm just learning how to use VBA.




Sub SaveFileWDeptName()
'
' SaveFileWDeptName Macro
' Macro recorded 10/24/2007 by compope
'
'
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\compope\Desktop\" & Sheet1.Range("C6").Value & "_" & Sheet1.Range("B1").Value & "_" & Sheet1.Range("B2").Value & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Range("B1").Select
End Sub

[Bob Phillips]

Sub SaveFileWDeptName()
Dim sPath As String

' Open the file dialog
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show

If .SelectedItems.Count > 0 Then
sPath = .SelectedItems(1)
ActiveWorkbook.SaveAs Filename:=sPath & Application.PathSeparator & Sheet1.Range("C6").Value & "_" & Sheet1.Range("B1").Value & "_" & Sheet1.Range("B2").Value & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Range("B1").Select
End If
End With
End Sub

[MWPope]

I'm getting a Run time error '438':Object does not support this property or method. The debug takes me to:

With Application.FileDialog(msoFileDialogFolderPicker)

Under System Information it says I'm running Microsoft Office Excel 2003

[Bob Phillips]

Should work. I too am running 2003 here.

[MWPope]

It turns out I have Excel 2000. Because I have Outlook 2003 the "System Information" tab showed Excel 2003.

Is there a way to write this code so it would work in both environments - 2000 and 2003?

[Bob Phillips]

The pre XL2002 way is



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

Private Type BROWSEINFO
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

'-------------------------------------------------------------
Function GetFolder(Optional ByVal Name As String = _
"Select a folder.") As String
'-------------------------------------------------------------
Dim bInfo As BROWSEINFO
Dim path As String
Dim oDialog As Long

bInfo.pidlRoot = 0& 'Root folder = Desktop

bInfo.lpszTitle = Name

bInfo.ulFlags = &H1 'Type of directory to Return
oDialog = SHBrowseForFolder(bInfo) 'display the dialog

'Parse the result
path = Space$(512)

GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If

End Function

[MWPope]

xld, can I ask for your help in modifying the SaveFileWDeptName subroutine to work with the above code? I just don't have enough background yet to decode the code. I'll be going to the store tomorrow to buy a VBA book to help me learn this. I appreciate the help you've given me so far.

[Bob Phillips]

.

[MWPope]

That works great. Thank you. I'll now study your code until I understand all the functions. Thanks again.

Mike