select dymanic path & prompt to save file in excel vba - excel

Hi i am looking dynamic path to be taken for uploading excel file and should ask where to save the file. here is my code.`where as i tried but it is taking only static path. Any help would be appreciated.
'To Combine Sheets
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'This line will need to be modified depending on location of source folder
FolderLocation = "U:\ECA" 'file location need to be dynamic
'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation
'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal) 'file name should be specified by user input and output file
'Iterate for each file in folder
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set WorkbookSource = Workbooks.Open(Filename:=FolderLocation & "\" & strFilename)
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
strFilename = Dir()
Loop
WorkbookDestination.Worksheets(1).Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=FolderLocation
Application.DisplayAlerts = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True`

This block of code is good once everything is running properly: Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = FalseUntil your code is completely debugged, though, it will make your life a nightmare. Comment those 3 out until this procedure is running the way you want it.
you appear to declare (Dim) some of your variables, but not all. I would strongly recommend adding Option Explicit to the top of all your code modules to force variable declaration prior to use - it helps prevent typos in variable names from messing things up down the road.
You assign SelectedFiles the return value from Application.GetOpenFilename, but don't ever use it. When it's assigned, you will have an array of file names that the user selected, and they will include the full path. This may provide the path information you need (the dialog box will allow the user to navigate to the desired folder), but I'm not sure, because...
You assign strFilename = Dir(FolderLocation & "\*.xls", vbNormal) which gives you the first *.xls file located in FolderLocation. You then loop through all the *.xls files there.
I would suggest that using your existing code, you could pull the path information from SelectedFiles like this:
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=False)
If InStrRev(SelectedFiles, "\") > 0 Then
FolderLocation = Left(SelectedFiles, InStrRev(SelectedFiles, "\"))
End If
Note that I changed Multiselect:=False to allow the user to only select one file - I don't see where you're using this variable anywhere else, so I've modified it to simply use it as a path picker. If that's incorrect, you'll have to make another modification to select the path. Otherwise, FolderLocation will now point to the directory that the user selected and you can continue your looping after that using the folder they selected.

Related

Do something while in VBA

I have a lot of files in one folder. What I want to do is add a column with the name of the file. I found a solution to this, but I want to optimize. Currently I am just adding the values from J2 to J1000 to make sure I cover all rows. This is not ideal as the amount of rows in each file differ. What I want to do is find a way to add the value matching the amount of rows that exists in the sheet.
I want to find a way to check if there is data in column A for each row and then add the value as long as there is some data in column A for each row.
My thoughts would be to do a while statement to check if each row in column A is different from an empty string and add the value as long as it is different from an empty string. However I am not sure how to implement this.
Here is my code:
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
Sheets(1).Range("j1").Value = "Date"
Sheets(1).Range("j2:j1000").Value = Mid(ActiveWorkbook.Name, 10, 10)
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub

Excel VBA Dir() Error when file type changes

I'm trying to better understand the Dir function. I have a Dir loop to take action on all .csv files in the directory, but when the loop comes across another file type, like .txt, it will error instead of moving on to the next .csv. item.
This is the relevant portion of my code.
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
strWorkbook = Dir(strSourceExcelLocation & "*.csv*")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport)
'Get next workbook
strWorkbook = Dir
'Close Excel workbook without making changes
wbktoExport.Close False
Loop
So if there are only .csv files in the directory, then this works fine. When it comes across another file type, an error occurs.
The error is on line
strWorkbook = Dir
Run-time error 5: Invalid procedure call or argument
Am I missing something with the way I use the wildcards in the .csv at the beginning?
Thank you
Solved my issue.
The problem seems to have been because when I called another procedure, I had another Dir in that sub to create a new folder if one didn't already exist. So basically I had a Dir in a Dir, which apparently is bad.
I moved the folder creation part to the very beginning of my procedure, so it is executed before I begin the Dir for looping through all the CSV files.
Option Explicit
Sub Loop_Dir_for_Excel_Workbooks()
Dim strWorkbook As String, wbktoExport As Workbook, strSourceExcelLocation As String, fldr As String, strTargetPDFLocation As String, d As String
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\"
'***** Creating a folder to save the PDFs in. Naming the folder with today's date *****
d = Format(Date, "mm-dd-yyyy")
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\" & d & "\"
If Len(Dir(strTargetPDFLocation, vbDirectory)) = 0 Then MkDir strTargetPDFLocation
fldr = InputBox("Input the EXACT Folder Name that you want to create PDFs for")
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
'Search all Excel files in the directory with .xls, .xlsx, xlsm extensions
strWorkbook = Dir(strSourceExcelLocation & "*.csv")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport, strTargetPDFLocation)
'Close Excel workbook without making changes
wbktoExport.Close False
'Get next workbook
strWorkbook = Dir
Loop
End Sub
Try to hardcode the path and give it a try again. Probably the error is something really small in the hardcoding. E.g., in the code below, replace C:\Users\username\Desktop\AAA\ with the path of the file. Then run it. Do not forget the last \. It should work:
Sub TestMe()
Dim workbookPath As String
workbookPath = Dir("C:\Users\username\Desktop\AAA\" & "*.csv")
Do While Len(workbookPath) > 0
Debug.Print workbookPath
workbookPath = Dir
Loop
End Sub

Access VBA script to open and save excel files on network drive doesnt save files

I have a script in Access that is supposed to loop through excel files in a shared network drive, open and save them.
When running the script on a local folder it works as intended, but when running it on the network drive a popup appears saying:'A file with this name already exists in this location, do you want to save it anyways? When I press yes the popup closes, but upon checking the timestamp of the files, non of them have been overwritten.
Here is the script:
Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
fileName = Dir()
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
app.Quit
End Sub
Ideally I wouldnt even receive those popups that I have to confirm manually and of course the files should be saved/overwritten.
Edit: I think the issue seems to be that the files are opened in read only mode. I tried fixing that issue by adding 'ReadOnly:=False, Notify:=False' to my Workbooks.Open command, but this does not work and the files still get opened in read only mode.
Second edit: Check below for a solution I answered my own question.
I found a solution to my specific issue so for anyone having the same issue in the future:
For me the issue was a result of the files being opened in 'read only' mode in excel.
To solve this I included
ActiveWorkbook.LockServerFile
into my loop.
This is the equivalent of pressing the 'edit workbook' button on excel.
My full code now looks like this:
Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Application.Echo False
DoCmd.SetWarnings False
Do While fileName <> ""
Workbooks.Open (directory & fileName)
fileName = Dir()
ActiveWorkbook.LockServerFile
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
app.Quit
DoCmd.SetWarnings True
Application.Echo True
End Sub
You can stop most message that excel asks the user by switching this option:
Application.DisplayAlerts
so in your code it would look like:
Public Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Application.DisplayAlerts = False
Do While fileName <> ""
Workbooks.Open directory & fileName
fileName = Dir()
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
Application.DisplayAlerts = True
app.Quit
End Sub

How can I open multiple Excel files and execute a contained macro on each?

I'm looking to open multiple Excel files and run the same macro (contained in each) on each file.
For example, I'd like to automatically open every file in h:\dbs and execute the CmdUpdate_Click macro within each file.
How might I go about this?
Try something like this. I expect you can research how to open the Visual Basic Editor and figure out where to paste this.
'Declare variables
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "B:\BIM Projects\"
.InitialView = msoFileDialogViewDetails
'Check if user canceled dialog box
'Exit if yes
If .Show = -1 Then
MsgBox "No Folder Selected"
Exit Sub
End If
End With
'Check if user canceled dialog box
'Exit if yes
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
'For each obj in the selected folder
For Each FileObj In FolderObj.Files
'Test if the file extension contains "xl" and make sure it's an Excel file before opening
If InStr(1, Right(FileObj.Name, Len(FileObj.Name) - InStr(1, FileObj.Name, ".")), "xl") = 1 Then
'Prevent the workbook from displaying
ActiveWindow.Visible = False
'Open the Workbook
Workbooks.Open (FolderObj & "\" & FileObj.Name)
'Run the Macro
Application.Run "'" & FolderObj & "\" & FileObj.Name & "'!CmdUpdate_Click"
'Save the Workbook
Workbooks(FileObj.Name).Save
'Close the Workbook
Workbooks(FileObj.Name.Close
End If
'Turn this back on
ActiveWindow.Visible = True
Next
I will caution you that this is based on some code I wrote for Word, so there are no guarantees it will work and I don't have time to test it. It will, however, give you a very good start if it doesn't.
Edit to Add: You may

Save numbered versions of excel files based on folder contents

I need code that saves incrementally numbered versions of a file based on whether similarly named files already exist in a specified folder.
For example,
Check for the prescence of currently open file, say named
"Inv_Dec_2015.xlsx" in a folder named "Reports".
If file exists, check for "Inv_Dec_2015_v1.xlsx" in "Reports".
If file exists, check for "Inv_Dec_2015_v2.xlsx" in "Reports".
If file exists, check for "Inv_Dec_2015_v3.xlsx" in "Reports".
If file does NOT exist, Save currently open file as "Inv_Dec_2015_v3.xlsx"
and so on till any number of versions......
I found the following two pieces of code on Ron de Bruin's website that can be used for something like this and modified it a bit to my purpose, but I don't know how use it to check for pre-existing files.
Would deeply appreciate any help with this.
Sub Rename_Store_Wbk()
Dim sPath As String
' Enter the path at which file is to be stored
sPath = ActiveSheet.Range("K1").Value & ActiveSheet.Range("K2").Value & ".xlsx"
' Check whether the file already exists by calling the FileExist function
If FileExist(sPath) = False Then
ActiveWorkbook.SaveAs Filename:=sPath, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
End Sub
Function FileExist(FilePath As String) As Boolean
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Reports\Inv_Dec_2015.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
See if the loop I added in here works for you:
Sub Rename_Store_Wbk()
Dim sPath As String
' Enter the path at which file is to be stored
sPath = ActiveSheet.Range("K1").Value & ActiveSheet.Range("K2").Value & ".xlsx"
If Not FileExists(sPath) Then
i = 1
Do
sPath = Left(sPath, Len(sPath) - 5) & "_v" & i & ".xlsx"
i = i + 1
Loop Until FileExists(sPath)
End If
ActiveWorkbook.SaveAs Filename:=sPath, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Resources