I am trying to automatically save a .xls file in a hardcoded location, in the .xlsx file format. I want the SaveAs dialog to be showing the hardcoded location, and the file name that has been coded in the "File Name:" field . This is so that all I need to do is click on the Save button.
However, the SaveAs dialog always end up showing C Drive, when I want to save my file in the H Drive.
The following are my codes:
Option Explicit
Sub externalRatingChangeFile()
'Declare the data type of the variables
Dim wks As Worksheet
Dim sFilename As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location to save the file to a variable
sFilename = "H:\testing file"
'Save as .xlsx file in the specific location stated earlier
'If there are errors in the code, set wks to nothing and end the process
On Error GoTo err_handler
ChDrive sFilename
ChDir sFilename
Application.Dialogs(xlDialogSaveAs).Show (sFilename & "\TestingFile - " & Format(Date, "YYYYMMDD") & ".xlsx")
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
Instead of showing the Save As Dialog box, just save directly to the folder.
Application.DisplayAlerts = False
wks.SaveAs (sFilename + "\TestingFile - " + Format(Date, "YYYYMMDD") + ".xlsx")
Application.DisplayAlerts = True
or
Application.DisplayAlerts = False
wks.SaveCopyAs (sFilename + "\TestingFile - " + Format(Date, "YYYYMMDD") + ".xlsx")
Application.DisplayAlerts = True
Lastly you could create your own Dialog Box to make sure you are saving in the correct location:
'Result = 2 is Cancel
'Result = 1 is Ok
result = MsgBox("Would You Like To Save in the Following Location: " + "H:\Test File....", vbOKCancel, "Save As")
While I prefer the Application.GetSaveAsFilename method (see this), setting the initial folder on a xlDialogSaveAs should be no problem providing that the original workbook has not been previously saved.
Sub externalRatingChangeFile()
Dim bSaved As Boolean
Dim xlsxFileFormat As XlFileFormat
'Declare the data type of the variables
Dim wks As Worksheet
Dim sFilename As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location to save the file to a variable
sFilename = "H:\testing file"
xlsxFileFormat = XlFileFormat.xlOpenXMLWorkbook
'Save as .xlsx file in the specific location stated earlier
On Error GoTo err_handler
bSaved = Application.Dialogs(xlDialogSaveAs).Show(Arg1:=sFilename & "\TestingFile - " & Format(Date, "YYYYMMDD"), _
arg2:=xlsxFileFormat)
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
Related
I would like to create a New workbook and name it as today's date and DE.
(Eg : 22.01.2018-DE)
Format(Date, "dd/mm/yyyy") & "-DE"
If the workbook is already existed or opened, then delete it or close it. Finally save the workbook. I used the code below but not working. Displaying object defined error. Help me
I need to rename Land-DE to 22.01.2018-DE.
Sub createlandDE()
Dim wb As Workbook
Set wb = Workbooks.add
ActiveWorkbook.Names.add Name:=Format(Date, "dd/mm/yyyy") & "-DE"
Dim path As String
Dim FSO As Object
path = "Q:\Job\Land-DE.xlsx" 'Need to rename the file here
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(path) Then
On Error Resume Next
Workbooks("Land-DE").Close False 'Workbook name must automatically come here
Kill path
wb.SaveAs path
Else
wb.SaveAs path
End If
How about this:
Sub createlandDE()
Dim wb As Workbook
Set wb = Workbooks.Add
NameValue = Format(Date, "dd-mm-yyyy") & "-DE"
Dim path As String
Dim FSO As Object
delpath = "Q:\Job\Land-DE.xlsx" 'Need to name the file to delete
path = "Q:\Job\" & NameValue & ".xlsx" 'Need to rename the file here
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(path) Then
On Error Resume Next
Workbooks(NameValue).Close False
Kill delpath
wb.SaveAs path
Else
wb.SaveAs path
End If
End Sub
Try with saving as:
Workbooks("Land-DE").SaveAs Filename:="Q:\Job\22.01.2018.xlsx"
Then delete the file with the old name.
To make it look better, consider saving "Q:\Job\22.01.2018.xlsx" as a String variable.
I believe you are editing the wrong property.
I would simply use ActiveWorkbook.Name = [your desired name]
I am trying to open a file from somewhere and also get the date when the opened file was created. However the line below gives me an error "Run Time Error, Automation error and Unspecified error". How can I fix this? Thanks.
MsgBox wb2.BuiltinDocumentProperties("Creation Date")
Private Sub CommandButton1_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Dim WS As Worksheet
Set wb1 = ActiveWorkbook
'Clear Summary tab
wb1.Worksheets("Summary").Cells.Clear
'Delete existing worksheet with name "Task List Data Export"
For Each WS In Worksheets
If WS.Name = "Task List Data Export" Then
Application.DisplayAlerts = False
Sheets("Task List Data Export").Delete
Application.DisplayAlerts = True
End
End If
Next
'Get the File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file")
If Ret1 = False Then Exit Sub
'Copy file
Set wb2 = Workbooks.Open(Ret1)
MsgBox wb2.BuiltinDocumentProperties("Creation Date")
wb2.Sheets(1).Select
wb2.Sheets(1).Copy After:=wb1.Sheets(2)
'Close opened file
wb2.Close savechanges:=False
Set wb2 = Nothing
Worksheets("Cover").Activate
End Sub
If Microsoft Excel doesn’t define a value for one of the built-in document properties, reading the Value property for that document property causes an error.
From Workbook.BuiltinDocumentProperties Property
There is always a file created date and hence it is quite surprising that you are getting that error. I have never got this error. Even a newly created file which has not been saved gives you a "File Created Date and Time".
Here is an alternative.
Dim CtdDate As String
Dim fs As Object, f As Object
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file")
If Ret1 = False Then Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(Ret1)
CtdDate = f.DateCreated
Set wb2 = Workbooks.Open(Ret1)
MsgBox CtdDate
I've created a excel spreadsheet template for our customers to populate and send back to us. I want to manually select their populated data and save it as a .csv to import into another piece of software. I, first, attempted this by recording a macro. This didn't work because different customers send different numbers of records.
I've tried snippets of code from online research and came up with this.
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
Function SaveAs(initialFilename As String)
On Error GoTo EndNow
SaveAs = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.ButtonName = "&Save As"
.initialFilename = initialFilename
.Title = "File Save As"
'.Execute
.Show
SaveAs = .SelectedItems(1)
End With
EndNow:
End Function
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
This worked really well except when I went back to look at the .csv in the folder it was the same worksheet not the selected columns.
Ultimately what I am looking to do is,
Manually select the columns I want
Run a macro that converts the selected columns to a .csv
Have the Save As Dialog Box appear
Navigate to the certain folder I want.
Here you go:
Sub MacroMan()
ChDrive "P:" '// <~~ change current drive to P:\
Dim copyRng As Excel.Range
Dim ThisWB As Excel.Workbook
Dim OtherWB As Excel.Workbook
Dim sName As String
'// set reference to the 'Master' workbook
Set ThisWB = ActiveWorkbook
'// assign selected range to 'copyRng'
Set copyRng = Application.InputBox(Prompt:="Select range to convert to CSV", Type:=8)
'// If the user selected a range, then proceed with rest of code:
If Not copyRng Is Nothing Then
'// Create a new workbook with 1 sheet.
Set OtherWB = Workbooks.Add(1)
'// Get A1, then expand this 'selection' to the same size as copyRng.
'// Then assign the value of copyRng to this area (similar to copy/paste)
OtherWB.Sheets(1).Range("A1").Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
'// Get save name for CSV file.
sName = Application.GetSaveAsFilename(FileFilter:="CSV files (*.csv), *.csv")
'// If the user entered a save name then proceed:
If Not LCase(sName) = "false" Then
'// Turn off alerts
Application.DisplayAlerts = False
'// Save the 'copy' workbook as a CSV file
OtherWB.SaveAs sName, xlCSV
'// Close the 'copy' workbook
OtherWB.Close
'// Turn alerts back on
Application.DisplayAlerts = True
End If
'// Make the 'Master' workbook the active workbook again
ThisWB.Activate
MsgBox "Conversion complete", vbInformation
End If
End Sub
This will allow you to manually select a range (including entire columns). It will then transfer said range onto a new sheet, save that sheet as a CSV, using the Save As dialog, and then close it afterwards.
There is workflow to fill in a sheet and mail it when you're done. The method to mail will send the current sheet as attachment, but it should directly create a new copy of the sheet where all your data is removed from.
I can clear the current sheet, but that's wrong, as I need to clear the new sheet. I have read about running macros on other workbooks, but it fails to run the macro. What's the best solution?
Sub SendData_Click()
If MsgBox("Sure to send?", vbYesNo, "Confirm") = vbYes Then
' Save current sheet
ActiveWorkbook.Save
' Send the current file
Mail_ActiveSheet
' Mark this sheet as sent
Worksheets("Data").Range("B6").Value = True
' Create a new emptied version
Create_New_Copy
MsgBox "Your data is sent"
End If
End Sub
Sub Create_New_Copy()
Dim Wb As Workbook
Dim NewFileName As String
Dim FileExtStr As String
Dim FilePath As String
Set Wb = ActiveWorkbook
NewFileName = "FileNameHere " & Format(DateAdd("d", 1, Now), "yyyy-mm-dd")
FileExtStr = "." & LCase(Right(Wb.Name, Len(Wb.Name) - InStrRev(Wb.Name, ".", , 1)))
FilePath = ActiveWorkbook.Path & "\" & NewFileName & FileExtStr
' # This is the problem, how to clear only the new file??
' Clear_Sheet_Invoices
' Save this sheet as the new file
Wb.SaveCopyAs FilePath
End Sub
Sub Clear_Sheet_Invoices()
Dim Ws As Worksheet
Set Ws = Worksheets("MyDataSheet")
' Remove all contents
Ws.Range("B2:F999").ClearContents
' Mark the "sent" flag for the new sheet to False
Worksheets("Data").Range("B6").Value = False
End Sub
As you might note, I am using ActiveWorkbook.SaveCopyAs to create a copy, and I have a Sub Clear_Sheet_Invoices which can clear all required data. How to run this sub on the new file?
I have thought to copy the MyDataSheet to a new sheet, clear the data sheet, save the new file and copy the sheet back. On opening a file, I check if a copy of the sheet is present and I will remove the sheet. Yeah, damn ugly, there should be a better way right? ;)
You can change the definition of Clear_Sheet_Invoices() in that way that it requires a parameter of Workbook type and it would clear worksheet "MyDataSheet" in this workbook.
Then you can invoke this sub and pass the newly created workbook as a parameter.
Below is the code you need to change to implement it:
Sub Clear_Sheet_Invoices(Wb As Workbook)
Dim Ws As Worksheet
Set Ws = Wb.Worksheets("MyDataSheet")
' Remove all contents
Ws.Range("B2:F999").ClearContents
' Mark the "sent" flag for the new sheet to False
Wb.Worksheets("Data").Range("B6").Value = False
End Sub
Sub Create_New_Copy()
Dim Wb As Workbook
Dim NewWb As Workbook
Dim NewFileName As String
Dim FileExtStr As String
Dim FilePath As String
Set Wb = ActiveWorkbook
NewFileName = "FileNameHere " & Format(DateAdd("d", 1, Now), "yyyy-mm-dd")
FileExtStr = "." & LCase(Right(Wb.Name, Len(Wb.Name) - InStrRev(Wb.Name, ".", , 1)))
FilePath = ActiveWorkbook.Path & "\" & NewFileName & FileExtStr
' Save this sheet as the new file
Wb.SaveCopyAs FilePath
Set NewWb = Excel.Workbooks.Open(FilePath)
' # This is the problem, how to clear only the new file??
Call Clear_Sheet_Invoices(NewWb)
Call NewWb.Close(True)
End Sub
Method SendData_Click doesn't require any changes.
I have a VB form in Access 2010, that opens a file dialog box to make a excel selection. I send the file path as string to my variable: directory (directory = strPath) to open the workbook and copy its contents to my current workbook. Which works fine if you intend to use the tool once. It's when you import one file, then another that's in the same directory the error occurs.
Non-working Example:
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\File2.xls, Import
Error:
Run-time error '1004':
A document with the name 'Tool.xlsm' is already open. You cannot open two documents with the same name, even if the documents are in different folders. To open the second document, either close the document that's currently open, or rename one of the documents.
Working Example (Separate Folders):
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\TestFolder\File2.xls, Import
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Dim strPath As String
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = strPath
FileName = Dir(directory & "*.xls")
Do While FileName <> ""
Workbooks.Open (directory & FileName)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("Tool.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("Tool.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub
In DEBUG mode it doesn't like
Workbooks.Open (directory & FileName)
Any suggestions on a way to eliminate this error?
First, between directory and FileName, i assume there is a "\".
secondly, simply check if the workbook is already opened:
dim wb as workbook
err.clear
on error resume next
set wb = Workbooks (FileName) 'assuming the "\" is not in FileName
if err<>0 or Wb is nothing then 'either one works , you dont need to test both
err.clear
set wb= Workbooks.Open (directory & FileName)
end if
on error goto 0
if you don't use application.enableevents=false, your opened Wb will trigger its workbook_open events !
I wanted to post the working code, maybe it will help someone in the future. Thanks again to those who left comments.
This code will open a file dialog, allow the user to select 1 excel file then copy all sheets from the selected file into the current workbook.
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to textbox1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Dim wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Err.Clear
On Error Resume Next
Set wb = Workbooks(FileName) 'assuming the "\" is not in FileName
If Err <> 0 Or wb Is Nothing Then 'either one works , you dont need to test both
Err.Clear
Set wb = Workbooks.Open(directory & TextBox1)
End If
On Error GoTo 0
FileName = Dir(directory & TextBox1)
Do While FileName <> ""
Workbooks.Open (directory & TextBox1)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub