Writing a code to save a file with a defined filename to a specific folder entered by the user. However the file is being saved in a location previous to the specified location. For example I provide file save path as "C:\Users\arorapr\Documents\PAT" but the file is saving it in the path "C:\Users\arorapr\Documents". I have written the below code.
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
End With
ActiveWorkbook.saveas Filename:=File_Name & ".xlsm", FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
Your challenge is that you're opening a file dialog, but not using the user's choice from that in the saveas. Try something along these lines:
Sub SaveFile()
Dim FolderName As String
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
' Pop up the folder-selection box to get the folder form the user:
FolderName = GetFolder()
' If the user didn't select anything, you can't save, so tell them so:
If FolderName = "" Then
MsgBox "No folder was selected. Program will terminate."
Exit Sub
End If
' Create a path by combining the file and folder names:
File_Name = FolderName & "\" & File_Name & ".xlsm"
ActiveWorkbook.SaveAs Filename:=File_Name, FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
' A separate function to get the folder name and return it as a string
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Hope that helps.
In your code, you are not saving the path of the selected folder to a variable. In the code below, the path is saved to the variable selectedFolder, which gets its value from fldr.SelectedItems(1). Then the path + "\" + YourFileName & .xlsm is saved:
Option Explicit
Sub TestMe()
Dim fldr As FileDialog
Dim selectedFolder As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.Show
selectedFolder = .SelectedItems(1)
End With
ActiveWorkbook.SaveAs Filename:=selectedFolder & "\" & "YourFileName" & ".xlsm"
End Sub
Or alternatively, you may use a function, returning the folder's path from here:
VBA - Folder Picker - set where to start
A robust funciton, that I am using to GetFolder is this one:
Option Explicit
Sub myPathForFolder()
Debug.Print GetFolder(Environ("USERPROFILE"))
End Sub
Function GetFolder(Optional InitialLocation As String) As String
On Error GoTo GetFolder_Error
Dim FolderDialog As FileDialog
Dim SelectedFolder As String
If Len(InitialLocation) = 0 Then InitialLocation = ThisWorkbook.Path
Set FolderDialog = Excel.Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.Title = "My Title For Dialog"
.AllowMultiSelect = False
.InitialFileName = InitialLocation
If .Show <> -1 Then GoTo GetFolder_Error
SelectedFolder = .SelectedItems(1)
End With
GetFolder = SelectedFolder
On Error GoTo 0
Exit Function
GetFolder_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ")
End Function
Related
I am trying to make a copy of a workbook that I have, based on list of IDs. I have got this to work OK if I hard code the path, however I can't figure out how to do this where specifying the path using msoFileDialogFolderPicker.
I have tried a number of variations depending on what I have found online and have got as far as below but stuck. Help appreciated.
Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"
With xFilepath
.Title = "Choose Destination"
.SHOW
mypath = .SelectedItems(1) & "\"
End With
mypath = mypath
Sheets("FILES").Range("A3").Select
For i = 1 To 3
Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")
ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
FileFormat = 50
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=mypath & Filename
Call DeleteQueries
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You can use the following code can be used to select folder and then you can append the folder path with file name.
Sub ChooseFolder()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
Filename = "Test.xlsx"
Filepath = sFolder + "\" + Filename
If sFolder <> "" Then ' if a file was chosen
MsgBox Filepath 'Use this for further processing
End If
End Sub
Following code can be used select single file.
Private Sub ChooseFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Excel File", "*.xlsx"
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
MsgBox txtFileName
End Sub
I have a code which picks file from a SourcePath then renames it and saves in DestPath. The code is working fine with hardcoded folder path for SourcePath (SourcePath = "C:\Invoices\Raw invoices"). however, it's not able to capture and retain the folderpath with msoFileDialogFolderPicker function. The code is unable to find the file in sourcepath and gives error as programmed.
Here is the sample data.
Here is the code I am using.
Sub Rename_invoices()
Dim SourcePath As String, DestPath As String, Fname As String, NewFName As String
Dim i As Long
SourcePath = GetFolder("C:\")
DestPath = "C:\Dunning Temp\"
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Not IsEmpty(Range("A" & i).Value) Then
NewFName = Range("B" & i).Value
'Search for the first file containing the string in column A
Fname = Dir(SourcePath & "*" & Range("A" & i).Value & "*")
If Fname <> vbNullString Then
FileCopy SourcePath & Fname, DestPath & NewFName
Else
MsgBox Range("A" & i).Value & " dosen't exist in the folder"
End If
End If
Next i
ActiveSheet.Close = False
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
The path your GetFolder Function returns will not end with a backslash \. As is, the pathname argument you pass to Dir in Fname = Dir(SourcePath & "*" & Range("A" & i).Value & "*") will be incorrect.
So change SourcePath = GetFolder("C:\") to SourcePath = GetFolder("C:\") & "\", or add a trailing backslash within your GetFolder function.
As #Mistella pointed out, using Debug.Print would easily highlight this issue.
how can I change the format from xlsm to xlsx. I need a script that will save a copy of the xlsm file with xlsx extension, but doesn't ask user to input file name, it needs to keep the original name, the only thing the user needs to do is select where to save the file.
Sub changeext()
Dim s_as As String
s_as = ThisWorkbook.FullName
s_as = Left(s_as, InStrRev(s_as, ".") - 1) & ".xlsx"
ThisWorkbook.SaveAs FileName:=s_as
Application.DisplayAlerts = False
End Sub
I think you only want to add a .xlxs copy not write over your macro enabled workbook. Try the below line of code, it should work, put your workbook name in "put Workbook name here", the file left open will be the .xlsx file.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & "Put Workbook Name here" & ".xlsx", FileFormat:=51, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
You need to create FolderPicker Function:
Sub changeext()
Dim objFolder As Object, objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ChooseFolder)
ThisWorkbook.SaveCopyAs Filename:=objFolder & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "xlsx"
End Sub
Function ChooseFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to save down the copy of this workbook"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
I am trying to get a fullpath and filename using the file dialog from MS Access VBA.
What I am trying to do is to open the file Dialog on button click by calling this function. This function should return the fullpath and filename that was selected from the filedialog.
I commented the loop part because I only want to select single file.
This function is returning an error Error: 0 after I select a file
So far this is my code.
Anyone can figure out what's wrong?
Thanks
Public Function SelectTheFile() As String
On Error GoTo SelectTheFile_ErrorHandler
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = False
.Title = "Please select one file"
If .Show = True Then
'For Each varFile In .SelectedItems
'SelectTheFile = varFile
'Debug.Print SelectTheFile
'Next
SelectTheFile = .SelectedItems(1)
Debug.Print SelectTheFile
Else
Debug.Print "Cancel"
End If
End With
SelectTheFile_ErrorHandler:
Set fd = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Function
your code always reach the SelectTheFile_ErrorHandler: section whatever the file dialog result
you must exit the function before that section
Public Function SelectTheFile() As String
On Error GoTo SelectTheFile_ErrorHandler
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = False
.Title = "Please select one file"
If .Show = True Then
'For Each varFile In .SelectedItems
'SelectTheFile = varFile
'Debug.Print SelectTheFile
'Next
SelectTheFile = .SelectedItems(1)
Debug.Print SelectTheFile
Else
Debug.Print "Cancel"
End If
End With
Exit Function '<==== exit here, otherwise code goes on to following section
SelectTheFile_ErrorHandler:
Set fDialog = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Function
Try just using this:
Application.GetOpenFilename
That works for me and saves the full file path without actually opening the file. Much simpler unless I am missing what you're trying to do. Read more here in the docs: https://msdn.microsoft.com/en-us/library/office/ff834966.aspx
The Code:
mNummer = InputBox("Please typ a number")
If mNummer = ""
Then MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= ""
Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" & Worksheets("Vorgaben").Range("B15"))
If Welle = "" Then MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "_" & Year& "_" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
The Question:
So here i combined 3 variables, which are asking for user Inputs with 3 messageboxes. Now the combined Version of it is in variable "mNummerGanz".
Now I would like to open any Excel file by going to any Directory and selecting it. But my macro should check if the Name of the selected Excel file is equals "mNummerGanz.xls". If yes, the file should be opened, if it is not equal to "mNummerGanz.xls" then it should print "error".
Does anyone have Suggestion for this ?
If I've understood correctly, you're building a string which you then want to test to see if it's a valid file name, and if so, open it?
In which case, this snippet should do that for you
If Len(Dir(outputpath & mNummerGanz)) <> 0 Then
Workbooks.Open (outputpath & mNummerGanz)
Else
MsgBox ("That file does not exist")
End If
It checks to see if the file exists (outputpath = folder location)
and if so, opens it.
I can help! Also in German :) Ich kann dir auf Deutsch helfen :)
mNummer = InputBox("Please typ a number")
If mNummer = "" Then
MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= "" Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" &
Worksheets("Vorgaben").Range("B15").Value
If Welle = "" Then
MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "" & Year& "" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
ANSWER:
'typical excel variables
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Retrieve Target FilePath From User
Set FldrPicker = Application.FileDialog(msoFileDialogFilePicker)
With FldrPicker
.Title = "Select A Target File"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
If myFile = "mNummerGanz.xls"
Debug.Print "myFile = " & myFile
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Do your stuff here, man.
With wb.Worksheets(1)
'add in your string manipulation / cell dumping here
'with a few lines
End With
'Close opened *.xls, save
wb.Close SaveChanges:=True
Else
GoTo ResetSettings
End If
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True